diff options
-rw-r--r-- | Changes | 107 | ||||
-rw-r--r-- | MANIFEST | 15 | ||||
-rw-r--r-- | MANIFEST.SKIP | 71 | ||||
-rw-r--r-- | META.json | 64 | ||||
-rw-r--r-- | META.yml | 36 | ||||
-rw-r--r-- | Makefile.PL | 78 | ||||
-rw-r--r-- | README | 217 | ||||
-rw-r--r-- | lib/Net/HTTP.pm | 294 | ||||
-rw-r--r-- | lib/Net/HTTP/Methods.pm | 648 | ||||
-rw-r--r-- | lib/Net/HTTP/NB.pm | 110 | ||||
-rw-r--r-- | lib/Net/HTTPS.pm | 111 | ||||
-rw-r--r-- | t/apache-https.t | 73 | ||||
-rw-r--r-- | t/apache.t | 67 | ||||
-rw-r--r-- | t/http-nb.t | 53 | ||||
-rw-r--r-- | t/http.t | 209 |
15 files changed, 2153 insertions, 0 deletions
@@ -0,0 +1,107 @@ +Release history for Net-HTTP + + +_______________________________________________________________________________ +2015-05-20 Net-HTTP 6.09 + +Karen Etheridge (1): + No changes since 6.08_002 + + + +_______________________________________________________________________________ +2015-05-02 Net-HTTP 6.08_002 + +Karen Etheridge (1): + fix foolish $VERSION error in 6.08_001 + + + +_______________________________________________________________________________ +2015-05-01 Net-HTTP 6.08_001 + +Mark Overmeer (1): + resolve issues with SSL by reading bytes still waiting to be read after + the initial 1024 bytes [RT#104122] + + + +_______________________________________________________________________________ +2014-07-23 Net-HTTP 6.07 + +Jason Fesler (1): + Opportunistically use IO::Socket::IP or IO::Socket::INET6. + Properly parse IPv6 literal addreses with optional port numbers. [RT#75618] + + + +_______________________________________________________________________________ +2013-03-10 Net-HTTP 6.06 + +Jesse Luehrs (1): + IO::Socket::SSL doesn't play well with select() [RT#81237] + + + +_______________________________________________________________________________ +2012-11-10 Net-HTTP 6.05 + +Gisle Aas (1): + Convert to Test::More style and disable test on Windows [RT#81090] + +Marinos Yannikos (1): + SSL broken for some servers [RT#81073] + + + +_______________________________________________________________________________ +2012-11-08 Net-HTTP 6.04 + +Gisle Aas (3): + Simpler handling of double chunked [RT#77240] + Check for timeouts before reading [RT#72676] + Fake can_read + +Dagfinn Ilmari Mannsåker (1): + Fix chunked decoding on temporary read error [RT#74431] + +Eric Wong (1): + NB: set http_bytes if read_entity_body hits EAGAIN on first read + +Jay Hannah (1): + chunked,chunked is invalid, but happens. :( Ignore all but the first. [RT#77240] + + + +_______________________________________________________________________________ +2012-02-16 Net-HTTP 6.03 + +Restore blocking override for Net::SSL [RT#72790] + +Restore perl-5.6 compatiblity. + + +_______________________________________________________________________________ +2011-11-21 Net-HTTP 6.02 + +Don't disable blocking method [RT#72580] +Don't stop on unrecognized Makefile.PL arguments [RT#68337] +Document Net:HTTPS [RT#71599] + + + +_______________________________________________________________________________ +2011-03-17 Net-HTTP 6.01 + +Don't run live test by default. Run 'perl Makefile.PL --live-tests' to enable. +More relaxed apache test; should pass even if proxies has added headers. + + + +_______________________________________________________________________________ +2011-02-27 Net-HTTP 6.00 + +Initial release of Net-HTTP as a separate distribution. There are no code +changes besides incrementing the version number since libwww-perl-5.837. + +The Net::HTTP module used to be bundled with the libwww-perl distribution. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..1457e2f --- /dev/null +++ b/MANIFEST @@ -0,0 +1,15 @@ +Changes +lib/Net/HTTP.pm +lib/Net/HTTP/Methods.pm +lib/Net/HTTP/NB.pm +lib/Net/HTTPS.pm +Makefile.PL +MANIFEST This list of files +MANIFEST.SKIP +README +t/apache-https.t +t/apache.t +t/http-nb.t +t/http.t +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..b60a532 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,71 @@ + +#!start included /Volumes/amaretto/Users/ether/perl5/perlbrew/perls/21.11/lib/5.21.11/ExtUtils/MANIFEST.SKIP +# Avoid version control files. +\bRCS\b +\bCVS\b +\bSCCS\b +,v$ +\B\.svn\b +\B\.git\b +\B\.gitignore\b +\b_darcs\b +\B\.cvsignore$ + +# Avoid VMS specific MakeMaker generated files +\bDescrip.MMS$ +\bDESCRIP.MMS$ +\bdescrip.mms$ + +# Avoid Makemaker generated and utility files. +\bMANIFEST\.bak +\bMakefile$ +\bblib/ +\bMakeMaker-\d +\bpm_to_blib\.ts$ +\bpm_to_blib$ +\bblibdirs\.ts$ # 6.18 through 6.25 generated this +\b_eumm/ # 7.05_05 and above + +# Avoid Module::Build generated and utility files. +\bBuild$ +\b_build/ +\bBuild.bat$ +\bBuild.COM$ +\bBUILD.COM$ +\bbuild.com$ + +# and Module::Build::Tiny generated files +\b_build_params$ + +# Avoid temp and backup files. +~$ +\.old$ +\#$ +\b\.# +\.bak$ +\.tmp$ +\.# +\.rej$ +\..*\.sw.?$ + +# Avoid OS-specific files/dirs +# Mac OSX metadata +\B\.DS_Store +# Mac OSX SMB mount metadata files +\B\._ + +# Avoid Devel::Cover and Devel::CoverX::Covered files. +\bcover_db\b +\bcovered\b + +# Avoid prove files +\B\.prove$ + +# Avoid MYMETA files +^MYMETA\. +#!end included /Volumes/amaretto/Users/ether/perl5/perlbrew/perls/21.11/lib/5.21.11/ExtUtils/MANIFEST.SKIP + + +\.ackrc +Net-HTTP-.*/ +Net-HTTP-.*.tar.gz diff --git a/META.json b/META.json new file mode 100644 index 0000000..a2dab4f --- /dev/null +++ b/META.json @@ -0,0 +1,64 @@ +{ + "abstract" : "Low-level HTTP connection (client)", + "author" : [ + "Gisle Aas <gisle@activestate.com>" + ], + "dynamic_config" : 0, + "generated_by" : "ExtUtils::MakeMaker version 7.052, CPAN::Meta::Converter version 2.150004", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Net-HTTP", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "recommends" : { + "IO::Socket::SSL" : "1.38" + }, + "requires" : { + "Compress::Raw::Zlib" : "0", + "IO::Select" : "0", + "IO::Socket::INET" : "0", + "IO::Uncompress::Gunzip" : "0", + "URI" : "0", + "perl" : "5.006002" + } + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "mailto" : "bug-Net-HTTP@rt.cpan.org", + "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Net-HTTP" + }, + "repository" : { + "type" : "git", + "url" : "https://github.com/libwww-perl/net-http.git", + "web" : "https://github.com/libwww-perl/net-http" + }, + "x_IRC" : "irc://irc.perl.org/#lwp", + "x_MailingList" : "mailto:libwww@perl.org" + }, + "version" : "6.09", + "x_serialization_backend" : "JSON::PP version 2.27300" +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..fae2394 --- /dev/null +++ b/META.yml @@ -0,0 +1,36 @@ +--- +abstract: 'Low-level HTTP connection (client)' +author: + - 'Gisle Aas <gisle@activestate.com>' +build_requires: + ExtUtils::MakeMaker: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 0 +generated_by: 'ExtUtils::MakeMaker version 7.052, CPAN::Meta::Converter version 2.150004' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Net-HTTP +no_index: + directory: + - t + - inc +recommends: + IO::Socket::SSL: '1.38' +requires: + Compress::Raw::Zlib: '0' + IO::Select: '0' + IO::Socket::INET: '0' + IO::Uncompress::Gunzip: '0' + URI: '0' + perl: '5.006002' +resources: + IRC: irc://irc.perl.org/#lwp + MailingList: mailto:libwww@perl.org + bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Net-HTTP + repository: https://github.com/libwww-perl/net-http.git +version: '6.09' +x_serialization_backend: 'CPAN::Meta::YAML version 0.016' + diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..331269f --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,78 @@ +#!perl -w + +require 5.006002; +use strict; +use ExtUtils::MakeMaker; +use Getopt::Long qw(GetOptions); +GetOptions(\my %opt, 'live-tests',) or warn "Usage: $0 [--live-tests]\n"; + +my $flag_file = "t/LIVE_TESTS"; +if ($opt{"live-tests"}) { + open(my $fh, ">", $flag_file) || die; +} +else { + unlink($flag_file); +} + +WriteMakefile( + NAME => 'Net::HTTP', + VERSION_FROM => 'lib/Net/HTTP.pm', + ABSTRACT_FROM => 'lib/Net/HTTP.pm', + AUTHOR => 'Gisle Aas <gisle@activestate.com>', + LICENSE => 'perl_5', + MIN_PERL_VERSION => 5.006002, + PREREQ_PM => { + 'IO::Socket::INET' => 0, + 'IO::Select' => 0, + 'Compress::Raw::Zlib' => 0, + 'IO::Uncompress::Gunzip' => 0, + 'URI' => 0, + }, + META_MERGE => { + 'meta-spec' => { version => 2 }, + dynamic_config => 0, + prereqs => { + runtime => { + recommends => { + 'IO::Socket::SSL' => "1.38", + }, + }, + }, + resources => { + repository => { + url => 'https://github.com/libwww-perl/net-http.git', + web => 'https://github.com/libwww-perl/net-http', + type => 'git', + }, + bugtracker => { + mailto => 'bug-Net-HTTP@rt.cpan.org', + web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Net-HTTP', + }, + x_MailingList => 'mailto:libwww@perl.org', + x_IRC => 'irc://irc.perl.org/#lwp', + }, + }, +); + + +BEGIN { + # compatibility with older versions of MakeMaker + my $developer = -f ".gitignore"; + my %mm_req = ( + LICENCE => 6.31, + META_MERGE => 6.45, + META_ADD => 6.45, + MIN_PERL_VERSION => 6.48, + ); + undef(*WriteMakefile); + *WriteMakefile = sub { + my %arg = @_; + for (keys %mm_req) { + unless (eval { ExtUtils::MakeMaker->VERSION($mm_req{$_}) }) { + warn "$_ $@" if $developer; + delete $arg{$_}; + } + } + ExtUtils::MakeMaker::WriteMakefile(%arg); + }; +} @@ -0,0 +1,217 @@ +NAME + Net::HTTP - Low-level HTTP connection (client) + +SYNOPSIS + use Net::HTTP; + my $s = Net::HTTP->new(Host => "www.perl.com") || die $@; + $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0"); + my($code, $mess, %h) = $s->read_response_headers; + + while (1) { + my $buf; + my $n = $s->read_entity_body($buf, 1024); + die "read failed: $!" unless defined $n; + last unless $n; + print $buf; + } + +DESCRIPTION + The `Net::HTTP' class is a low-level HTTP client. An instance of the + `Net::HTTP' class represents a connection to an HTTP server. The HTTP + protocol is described in RFC 2616. The `Net::HTTP' class supports + `HTTP/1.0' and `HTTP/1.1'. + + `Net::HTTP' is a sub-class of `IO::Socket::INET'. You can mix the + methods described below with reading and writing from the socket + directly. This is not necessary a good idea, unless you know what you + are doing. + + The following methods are provided (in addition to those of + `IO::Socket::INET'): + + $s = Net::HTTP->new( %options ) + The `Net::HTTP' constructor method takes the same options as + `IO::Socket::INET''s as well as these: + + Host: Initial host attribute value + KeepAlive: Initial keep_alive attribute value + SendTE: Initial send_te attribute_value + HTTPVersion: Initial http_version attribute value + PeerHTTPVersion: Initial peer_http_version attribute value + MaxLineLength: Initial max_line_length attribute value + MaxHeaderLines: Initial max_header_lines attribute value + + The `Host' option is also the default for `IO::Socket::INET''s + `PeerAddr'. The `PeerPort' defaults to 80 if not provided. + + The `Listen' option provided by `IO::Socket::INET''s constructor + method is not allowed. + + If unable to connect to the given HTTP server then the constructor + returns `undef' and $@ contains the reason. After a successful + connect, a `Net:HTTP' object is returned. + + $s->host + Get/set the default value of the `Host' header to send. The $host + must not be set to an empty string (or `undef') for HTTP/1.1. + + $s->keep_alive + Get/set the *keep-alive* value. If this value is TRUE then the + request will be sent with headers indicating that the server should + try to keep the connection open so that multiple requests can be + sent. + + The actual headers set will depend on the value of the + `http_version' and `peer_http_version' attributes. + + $s->send_te + Get/set the a value indicating if the request will be sent with a + "TE" header to indicate the transfer encodings that the server can + choose to use. The list of encodings announced as accepted by this + client depends on availability of the following modules: + `Compress::Raw::Zlib' for *deflate*, and `IO::Compress::Gunzip' for + *gzip*. + + $s->http_version + Get/set the HTTP version number that this client should announce. + This value can only be set to "1.0" or "1.1". The default is "1.1". + + $s->peer_http_version + Get/set the protocol version number of our peer. This value will + initially be "1.0", but will be updated by a successful + read_response_headers() method call. + + $s->max_line_length + Get/set a limit on the length of response line and response header + lines. The default is 8192. A value of 0 means no limit. + + $s->max_header_length + Get/set a limit on the number of header lines that a response can + have. The default is 128. A value of 0 means no limit. + + $s->format_request($method, $uri, %headers, [$content]) + Format a request message and return it as a string. If the headers + do not include a `Host' header, then a header is inserted with the + value of the `host' attribute. Headers like `Connection' and + `Keep-Alive' might also be added depending on the status of the + `keep_alive' attribute. + + If $content is given (and it is non-empty), then a `Content-Length' + header is automatically added unless it was already present. + + $s->write_request($method, $uri, %headers, [$content]) + Format and send a request message. Arguments are the same as for + format_request(). Returns true if successful. + + $s->format_chunk( $data ) + Returns the string to be written for the given chunk of data. + + $s->write_chunk($data) + Will write a new chunk of request entity body data. This method + should only be used if the `Transfer-Encoding' header with a value + of `chunked' was sent in the request. Note, writing zero-length data + is a no-op. Use the write_chunk_eof() method to signal end of entity + body data. + + Returns true if successful. + + $s->format_chunk_eof( %trailers ) + Returns the string to be written for signaling EOF when a + `Transfer-Encoding' of `chunked' is used. + + $s->write_chunk_eof( %trailers ) + Will write eof marker for chunked data and optional trailers. Note + that trailers should not really be used unless is was signaled with + a `Trailer' header. + + Returns true if successful. + + ($code, $mess, %headers) = $s->read_response_headers( %opts ) + Read response headers from server and return it. The $code is the 3 + digit HTTP status code (see HTTP::Status) and $mess is the textual + message that came with it. Headers are then returned as key/value + pairs. Since key letter casing is not normalized and the same key + can even occur multiple times, assigning these values directly to a + hash is not wise. Only the $code is returned if this method is + called in scalar context. + + As a side effect this method updates the 'peer_http_version' + attribute. + + Options might be passed in as key/value pairs. There are currently + only two options supported; `laxed' and `junk_out'. + + The `laxed' option will make read_response_headers() more forgiving + towards servers that have not learned how to speak HTTP properly. + The `laxed' option is a boolean flag, and is enabled by passing in a + TRUE value. The `junk_out' option can be used to capture bad header + lines when `laxed' is enabled. The value should be an array + reference. Bad header lines will be pushed onto the array. + + The `laxed' option must be specified in order to communicate with + pre-HTTP/1.0 servers that don't describe the response outcome or the + data they send back with a header block. For these servers + peer_http_version is set to "0.9" and this method returns (200, + "Assumed OK"). + + The method will raise an exception (die) if the server does not + speak proper HTTP or if the `max_line_length' or `max_header_length' + limits are reached. If the `laxed' option is turned on and + `max_line_length' and `max_header_length' checks are turned off, + then no exception will be raised and this method will always return + a response code. + + $n = $s->read_entity_body($buf, $size); + Reads chunks of the entity body content. Basically the same + interface as for read() and sysread(), but the buffer offset + argument is not supported yet. This method should only be called + after a successful read_response_headers() call. + + The return value will be `undef' on read errors, 0 on EOF, -1 if no + data could be returned this time, otherwise the number of bytes + assigned to $buf. The $buf is set to "" when the return value is -1. + + You normally want to retry this call if this function returns either + -1 or `undef' with `$!' as EINTR or EAGAIN (see Errno). EINTR can + happen if the application catches signals and EAGAIN can happen if + you made the socket non-blocking. + + This method will raise exceptions (die) if the server does not speak + proper HTTP. This can only happen when reading chunked data. + + %headers = $s->get_trailers + After read_entity_body() has returned 0 to indicate end of the + entity body, you might call this method to pick up any trailers. + + $s->_rbuf + Get/set the read buffer content. The read_response_headers() and + read_entity_body() methods use an internal buffer which they will + look for data before they actually sysread more from the socket + itself. If they read too much, the remaining data will be left in + this buffer. + + $s->_rbuf_length + Returns the number of bytes in the read buffer. This should always + be the same as: + + length($s->_rbuf) + + but might be more efficient. + +SUBCLASSING + The read_response_headers() and read_entity_body() will invoke the + sysread() method when they need more data. Subclasses might want to + override this method to control how reading takes place. + + The object itself is a glob. Subclasses should avoid using hash key + names prefixed with `http_' and `io_'. + +SEE ALSO + LWP, IO::Socket::INET, Net::HTTP::NB + +COPYRIGHT + Copyright 2001-2003 Gisle Aas. + + This library is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + diff --git a/lib/Net/HTTP.pm b/lib/Net/HTTP.pm new file mode 100644 index 0000000..0c923ed --- /dev/null +++ b/lib/Net/HTTP.pm @@ -0,0 +1,294 @@ +package Net::HTTP; + +use strict; +use vars qw($VERSION @ISA $SOCKET_CLASS); + +$VERSION = "6.09"; +$VERSION = eval $VERSION; + +unless ($SOCKET_CLASS) { + # Try several, in order of capability and preference + if (eval { require IO::Socket::IP }) { + $SOCKET_CLASS = "IO::Socket::IP"; # IPv4+IPv6 + } elsif (eval { require IO::Socket::INET6 }) { + $SOCKET_CLASS = "IO::Socket::INET6"; # IPv4+IPv6 + } elsif (eval { require IO::Socket::INET }) { + $SOCKET_CLASS = "IO::Socket::INET"; # IPv4 only + } else { + require IO::Socket; + $SOCKET_CLASS = "IO::Socket::INET"; + } +} +require Net::HTTP::Methods; +require Carp; + +@ISA = ($SOCKET_CLASS, 'Net::HTTP::Methods'); + +sub new { + my $class = shift; + Carp::croak("No Host option provided") unless @_; + $class->SUPER::new(@_); +} + +sub configure { + my($self, $cnf) = @_; + $self->http_configure($cnf); +} + +sub http_connect { + my($self, $cnf) = @_; + $self->SUPER::configure($cnf); +} + +1; + +__END__ + +=head1 NAME + +Net::HTTP - Low-level HTTP connection (client) + +=head1 SYNOPSIS + + use Net::HTTP; + my $s = Net::HTTP->new(Host => "www.perl.com") || die $@; + $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0"); + my($code, $mess, %h) = $s->read_response_headers; + + while (1) { + my $buf; + my $n = $s->read_entity_body($buf, 1024); + die "read failed: $!" unless defined $n; + last unless $n; + print $buf; + } + +=head1 DESCRIPTION + +The C<Net::HTTP> class is a low-level HTTP client. An instance of the +C<Net::HTTP> class represents a connection to an HTTP server. The +HTTP protocol is described in RFC 2616. The C<Net::HTTP> class +supports C<HTTP/1.0> and C<HTTP/1.1>. + +C<Net::HTTP> is a sub-class of one of C<IO::Socket::IP> (IPv6+IPv4), +C<IO::Socket::INET6> (IPv6+IPv4), or C<IO::Socket::INET> (IPv4 only). +You can mix the methods described below with reading and writing from the +socket directly. This is not necessary a good idea, unless you know what +you are doing. + +The following methods are provided (in addition to those of +C<IO::Socket::INET>): + +=over + +=item $s = Net::HTTP->new( %options ) + +The C<Net::HTTP> constructor method takes the same options as +C<IO::Socket::INET>'s as well as these: + + Host: Initial host attribute value + KeepAlive: Initial keep_alive attribute value + SendTE: Initial send_te attribute_value + HTTPVersion: Initial http_version attribute value + PeerHTTPVersion: Initial peer_http_version attribute value + MaxLineLength: Initial max_line_length attribute value + MaxHeaderLines: Initial max_header_lines attribute value + +The C<Host> option is also the default for C<IO::Socket::INET>'s +C<PeerAddr>. The C<PeerPort> defaults to 80 if not provided. +The C<PeerPort> specification can also be embedded in the C<PeerAddr> +by preceding it with a ":", and closing the IPv6 address on brackets "[]" if +necessary: "192.0.2.1:80","[2001:db8::1]:80","any.example.com:80". + +The C<Listen> option provided by C<IO::Socket::INET>'s constructor +method is not allowed. + +If unable to connect to the given HTTP server then the constructor +returns C<undef> and $@ contains the reason. After a successful +connect, a C<Net:HTTP> object is returned. + +=item $s->host + +Get/set the default value of the C<Host> header to send. The $host +must not be set to an empty string (or C<undef>) for HTTP/1.1. + +=item $s->keep_alive + +Get/set the I<keep-alive> value. If this value is TRUE then the +request will be sent with headers indicating that the server should try +to keep the connection open so that multiple requests can be sent. + +The actual headers set will depend on the value of the C<http_version> +and C<peer_http_version> attributes. + +=item $s->send_te + +Get/set the a value indicating if the request will be sent with a "TE" +header to indicate the transfer encodings that the server can choose to +use. The list of encodings announced as accepted by this client depends +on availability of the following modules: C<Compress::Raw::Zlib> for +I<deflate>, and C<IO::Compress::Gunzip> for I<gzip>. + +=item $s->http_version + +Get/set the HTTP version number that this client should announce. +This value can only be set to "1.0" or "1.1". The default is "1.1". + +=item $s->peer_http_version + +Get/set the protocol version number of our peer. This value will +initially be "1.0", but will be updated by a successful +read_response_headers() method call. + +=item $s->max_line_length + +Get/set a limit on the length of response line and response header +lines. The default is 8192. A value of 0 means no limit. + +=item $s->max_header_length + +Get/set a limit on the number of header lines that a response can +have. The default is 128. A value of 0 means no limit. + +=item $s->format_request($method, $uri, %headers, [$content]) + +Format a request message and return it as a string. If the headers do +not include a C<Host> header, then a header is inserted with the value +of the C<host> attribute. Headers like C<Connection> and +C<Keep-Alive> might also be added depending on the status of the +C<keep_alive> attribute. + +If $content is given (and it is non-empty), then a C<Content-Length> +header is automatically added unless it was already present. + +=item $s->write_request($method, $uri, %headers, [$content]) + +Format and send a request message. Arguments are the same as for +format_request(). Returns true if successful. + +=item $s->format_chunk( $data ) + +Returns the string to be written for the given chunk of data. + +=item $s->write_chunk($data) + +Will write a new chunk of request entity body data. This method +should only be used if the C<Transfer-Encoding> header with a value of +C<chunked> was sent in the request. Note, writing zero-length data is +a no-op. Use the write_chunk_eof() method to signal end of entity +body data. + +Returns true if successful. + +=item $s->format_chunk_eof( %trailers ) + +Returns the string to be written for signaling EOF when a +C<Transfer-Encoding> of C<chunked> is used. + +=item $s->write_chunk_eof( %trailers ) + +Will write eof marker for chunked data and optional trailers. Note +that trailers should not really be used unless is was signaled +with a C<Trailer> header. + +Returns true if successful. + +=item ($code, $mess, %headers) = $s->read_response_headers( %opts ) + +Read response headers from server and return it. The $code is the 3 +digit HTTP status code (see L<HTTP::Status>) and $mess is the textual +message that came with it. Headers are then returned as key/value +pairs. Since key letter casing is not normalized and the same key can +even occur multiple times, assigning these values directly to a hash +is not wise. Only the $code is returned if this method is called in +scalar context. + +As a side effect this method updates the 'peer_http_version' +attribute. + +Options might be passed in as key/value pairs. There are currently +only two options supported; C<laxed> and C<junk_out>. + +The C<laxed> option will make read_response_headers() more forgiving +towards servers that have not learned how to speak HTTP properly. The +C<laxed> option is a boolean flag, and is enabled by passing in a TRUE +value. The C<junk_out> option can be used to capture bad header lines +when C<laxed> is enabled. The value should be an array reference. +Bad header lines will be pushed onto the array. + +The C<laxed> option must be specified in order to communicate with +pre-HTTP/1.0 servers that don't describe the response outcome or the +data they send back with a header block. For these servers +peer_http_version is set to "0.9" and this method returns (200, +"Assumed OK"). + +The method will raise an exception (die) if the server does not speak +proper HTTP or if the C<max_line_length> or C<max_header_length> +limits are reached. If the C<laxed> option is turned on and +C<max_line_length> and C<max_header_length> checks are turned off, +then no exception will be raised and this method will always +return a response code. + +=item $n = $s->read_entity_body($buf, $size); + +Reads chunks of the entity body content. Basically the same interface +as for read() and sysread(), but the buffer offset argument is not +supported yet. This method should only be called after a successful +read_response_headers() call. + +The return value will be C<undef> on read errors, 0 on EOF, -1 if no data +could be returned this time, otherwise the number of bytes assigned +to $buf. The $buf is set to "" when the return value is -1. + +You normally want to retry this call if this function returns either +-1 or C<undef> with C<$!> as EINTR or EAGAIN (see L<Errno>). EINTR +can happen if the application catches signals and EAGAIN can happen if +you made the socket non-blocking. + +This method will raise exceptions (die) if the server does not speak +proper HTTP. This can only happen when reading chunked data. + +=item %headers = $s->get_trailers + +After read_entity_body() has returned 0 to indicate end of the entity +body, you might call this method to pick up any trailers. + +=item $s->_rbuf + +Get/set the read buffer content. The read_response_headers() and +read_entity_body() methods use an internal buffer which they will look +for data before they actually sysread more from the socket itself. If +they read too much, the remaining data will be left in this buffer. + +=item $s->_rbuf_length + +Returns the number of bytes in the read buffer. This should always be +the same as: + + length($s->_rbuf) + +but might be more efficient. + +=back + +=head1 SUBCLASSING + +The read_response_headers() and read_entity_body() will invoke the +sysread() method when they need more data. Subclasses might want to +override this method to control how reading takes place. + +The object itself is a glob. Subclasses should avoid using hash key +names prefixed with C<http_> and C<io_>. + +=head1 SEE ALSO + +L<LWP>, L<IO::Socket::INET>, L<Net::HTTP::NB> + +=head1 COPYRIGHT + +Copyright 2001-2003 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/lib/Net/HTTP/Methods.pm b/lib/Net/HTTP/Methods.pm new file mode 100644 index 0000000..3c3c5ca --- /dev/null +++ b/lib/Net/HTTP/Methods.pm @@ -0,0 +1,648 @@ +package Net::HTTP::Methods; + +require 5.005; # 4-arg substr + +use strict; +use vars qw($VERSION); +use URI; + +$VERSION = "6.09"; +$VERSION = eval $VERSION; + +my $CRLF = "\015\012"; # "\r\n" is not portable + +*_bytes = defined(&utf8::downgrade) ? + sub { + unless (utf8::downgrade($_[0], 1)) { + require Carp; + Carp::croak("Wide character in HTTP request (bytes required)"); + } + return $_[0]; + } + : + sub { + return $_[0]; + }; + + +sub new { + my $class = shift; + unshift(@_, "Host") if @_ == 1; + my %cnf = @_; + require Symbol; + my $self = bless Symbol::gensym(), $class; + return $self->http_configure(\%cnf); +} + +sub http_configure { + my($self, $cnf) = @_; + + die "Listen option not allowed" if $cnf->{Listen}; + my $explicit_host = (exists $cnf->{Host}); + my $host = delete $cnf->{Host}; + my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost}; + if (!$peer) { + die "No Host option provided" unless $host; + $cnf->{PeerAddr} = $peer = $host; + } + + # CONNECTIONS + # PREFER: port number from PeerAddr, then PeerPort, then http_default_port + my $peer_uri = URI->new("http://$peer"); + $cnf->{"PeerPort"} = $peer_uri->_port || $cnf->{PeerPort} || $self->http_default_port; + $cnf->{"PeerAddr"} = $peer_uri->host; + + # HOST header: + # If specified but blank, ignore. + # If specified with a value, add the port number + # If not specified, set to PeerAddr and port number + # ALWAYS: If IPv6 address, use [brackets] (thanks to the URI package) + # ALWAYS: omit port number if http_default_port + if (($host) || (! $explicit_host)) { + my $uri = ($explicit_host) ? URI->new("http://$host") : $peer_uri->clone; + if (!$uri->_port) { + # Always use *our* $self->http_default_port instead of URI's (Covers HTTP, HTTPS) + $uri->port( $cnf->{PeerPort} || $self->http_default_port); + } + my $host_port = $uri->host_port; # Returns host:port or [ipv6]:port + my $remove = ":" . $self->http_default_port; # we want to remove the default port number + if (substr($host_port,0-length($remove)) eq $remove) { + substr($host_port,0-length($remove)) = ""; + } + $host = $host_port; + } + + $cnf->{Proto} = 'tcp'; + + my $keep_alive = delete $cnf->{KeepAlive}; + my $http_version = delete $cnf->{HTTPVersion}; + $http_version = "1.1" unless defined $http_version; + my $peer_http_version = delete $cnf->{PeerHTTPVersion}; + $peer_http_version = "1.0" unless defined $peer_http_version; + my $send_te = delete $cnf->{SendTE}; + my $max_line_length = delete $cnf->{MaxLineLength}; + $max_line_length = 8*1024 unless defined $max_line_length; + my $max_header_lines = delete $cnf->{MaxHeaderLines}; + $max_header_lines = 128 unless defined $max_header_lines; + + return undef unless $self->http_connect($cnf); + + $self->host($host); + $self->keep_alive($keep_alive); + $self->send_te($send_te); + $self->http_version($http_version); + $self->peer_http_version($peer_http_version); + $self->max_line_length($max_line_length); + $self->max_header_lines($max_header_lines); + + ${*$self}{'http_buf'} = ""; + + return $self; +} + +sub http_default_port { + 80; +} + +# set up property accessors +for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) { + my $prop_name = "http_" . $method; + no strict 'refs'; + *$method = sub { + my $self = shift; + my $old = ${*$self}{$prop_name}; + ${*$self}{$prop_name} = shift if @_; + return $old; + }; +} + +# we want this one to be a bit smarter +sub http_version { + my $self = shift; + my $old = ${*$self}{'http_version'}; + if (@_) { + my $v = shift; + $v = "1.0" if $v eq "1"; # float + unless ($v eq "1.0" or $v eq "1.1") { + require Carp; + Carp::croak("Unsupported HTTP version '$v'"); + } + ${*$self}{'http_version'} = $v; + } + $old; +} + +sub format_request { + my $self = shift; + my $method = shift; + my $uri = shift; + + my $content = (@_ % 2) ? pop : ""; + + for ($method, $uri) { + require Carp; + Carp::croak("Bad method or uri") if /\s/ || !length; + } + + push(@{${*$self}{'http_request_method'}}, $method); + my $ver = ${*$self}{'http_version'}; + my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0"; + + my @h; + my @connection; + my %given = (host => 0, "content-length" => 0, "te" => 0); + while (@_) { + my($k, $v) = splice(@_, 0, 2); + my $lc_k = lc($k); + if ($lc_k eq "connection") { + $v =~ s/^\s+//; + $v =~ s/\s+$//; + push(@connection, split(/\s*,\s*/, $v)); + next; + } + if (exists $given{$lc_k}) { + $given{$lc_k}++; + } + push(@h, "$k: $v"); + } + + if (length($content) && !$given{'content-length'}) { + push(@h, "Content-Length: " . length($content)); + } + + my @h2; + if ($given{te}) { + push(@connection, "TE") unless grep lc($_) eq "te", @connection; + } + elsif ($self->send_te && gunzip_ok()) { + # gzip is less wanted since the IO::Uncompress::Gunzip interface for + # it does not really allow chunked decoding to take place easily. + push(@h2, "TE: deflate,gzip;q=0.3"); + push(@connection, "TE"); + } + + unless (grep lc($_) eq "close", @connection) { + if ($self->keep_alive) { + if ($peer_ver eq "1.0") { + # from looking at Netscape's headers + push(@h2, "Keep-Alive: 300"); + unshift(@connection, "Keep-Alive"); + } + } + else { + push(@connection, "close") if $ver ge "1.1"; + } + } + push(@h2, "Connection: " . join(", ", @connection)) if @connection; + unless ($given{host}) { + my $h = ${*$self}{'http_host'}; + push(@h2, "Host: $h") if $h; + } + + return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content)); +} + + +sub write_request { + my $self = shift; + $self->print($self->format_request(@_)); +} + +sub format_chunk { + my $self = shift; + return $_[0] unless defined($_[0]) && length($_[0]); + return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF); +} + +sub write_chunk { + my $self = shift; + return 1 unless defined($_[0]) && length($_[0]); + $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF)); +} + +sub format_chunk_eof { + my $self = shift; + my @h; + while (@_) { + push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2)); + } + return _bytes(join("", "0$CRLF", @h, $CRLF)); +} + +sub write_chunk_eof { + my $self = shift; + $self->print($self->format_chunk_eof(@_)); +} + + +sub my_read { + die if @_ > 3; + my $self = shift; + my $len = $_[1]; + for (${*$self}{'http_buf'}) { + if (length) { + $_[0] = substr($_, 0, $len, ""); + return length($_[0]); + } + else { + die "read timeout" unless $self->can_read; + return $self->sysread($_[0], $len); + } + } +} + + +sub my_readline { + my $self = shift; + my $what = shift; + for (${*$self}{'http_buf'}) { + my $max_line_length = ${*$self}{'http_max_line_length'}; + my $pos; + while (1) { + # find line ending + $pos = index($_, "\012"); + last if $pos >= 0; + die "$what line too long (limit is $max_line_length)" + if $max_line_length && length($_) > $max_line_length; + + # need to read more data to find a line ending + my $new_bytes = 0; + + READ: + { # wait until bytes start arriving + $self->can_read + or die "read timeout"; + + # consume all incoming bytes + while(1) { + my $bytes_read = $self->sysread($_, 1024, length); + if(defined $bytes_read) { + $new_bytes += $bytes_read; + last if $bytes_read < 1024; + } + elsif($!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK}) { + redo READ; + } + else { + # if we have already accumulated some data let's at + # least return that as a line + length or die "$what read failed: $!"; + last; + } + } + + # no line-ending, no new bytes + return length($_) ? substr($_, 0, length($_), "") : undef + if $new_bytes==0; + } + } + die "$what line too long ($pos; limit is $max_line_length)" + if $max_line_length && $pos > $max_line_length; + + my $line = substr($_, 0, $pos+1, ""); + $line =~ s/(\015?\012)\z// || die "Assert"; + return wantarray ? ($line, $1) : $line; + } +} + + +sub can_read { + my $self = shift; + return 1 unless defined(fileno($self)); + return 1 if $self->isa('IO::Socket::SSL') && $self->pending; + + # With no timeout, wait forever. An explicit timeout of 0 can be + # used to just check if the socket is readable without waiting. + my $timeout = @_ ? shift : (${*$self}{io_socket_timeout} || undef); + + my $fbits = ''; + vec($fbits, fileno($self), 1) = 1; + SELECT: + { + my $before; + $before = time if $timeout; + my $nfound = select($fbits, undef, undef, $timeout); + if ($nfound < 0) { + if ($!{EINTR} || $!{EAGAIN}) { + # don't really think EAGAIN can happen here + if ($timeout) { + $timeout -= time - $before; + $timeout = 0 if $timeout < 0; + } + redo SELECT; + } + die "select failed: $!"; + } + return $nfound > 0; + } +} + + +sub _rbuf { + my $self = shift; + if (@_) { + for (${*$self}{'http_buf'}) { + my $old; + $old = $_ if defined wantarray; + $_ = shift; + return $old; + } + } + else { + return ${*$self}{'http_buf'}; + } +} + +sub _rbuf_length { + my $self = shift; + return length ${*$self}{'http_buf'}; +} + + +sub _read_header_lines { + my $self = shift; + my $junk_out = shift; + + my @headers; + my $line_count = 0; + my $max_header_lines = ${*$self}{'http_max_header_lines'}; + while (my $line = my_readline($self, 'Header')) { + if ($line =~ /^(\S+?)\s*:\s*(.*)/s) { + push(@headers, $1, $2); + } + elsif (@headers && $line =~ s/^\s+//) { + $headers[-1] .= " " . $line; + } + elsif ($junk_out) { + push(@$junk_out, $line); + } + else { + die "Bad header: '$line'\n"; + } + if ($max_header_lines) { + $line_count++; + if ($line_count >= $max_header_lines) { + die "Too many header lines (limit is $max_header_lines)"; + } + } + } + return @headers; +} + + +sub read_response_headers { + my($self, %opt) = @_; + my $laxed = $opt{laxed}; + + my($status, $eol) = my_readline($self, 'Status'); + unless (defined $status) { + die "Server closed connection without sending any data back"; + } + + my($peer_ver, $code, $message) = split(/\s+/, $status, 3); + if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) { + die "Bad response status line: '$status'" unless $laxed; + # assume HTTP/0.9 + ${*$self}{'http_peer_http_version'} = "0.9"; + ${*$self}{'http_status'} = "200"; + substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || ""); + return 200 unless wantarray; + return (200, "Assumed OK"); + }; + + ${*$self}{'http_peer_http_version'} = $peer_ver; + ${*$self}{'http_status'} = $code; + + my $junk_out; + if ($laxed) { + $junk_out = $opt{junk_out} || []; + } + my @headers = $self->_read_header_lines($junk_out); + + # pick out headers that read_entity_body might need + my @te; + my $content_length; + for (my $i = 0; $i < @headers; $i += 2) { + my $h = lc($headers[$i]); + if ($h eq 'transfer-encoding') { + my $te = $headers[$i+1]; + $te =~ s/^\s+//; + $te =~ s/\s+$//; + push(@te, $te) if length($te); + } + elsif ($h eq 'content-length') { + # ignore bogus and overflow values + if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) { + $content_length = $1; + } + } + } + ${*$self}{'http_te'} = join(",", @te); + ${*$self}{'http_content_length'} = $content_length; + ${*$self}{'http_first_body'}++; + delete ${*$self}{'http_trailers'}; + return $code unless wantarray; + return ($code, $message, @headers); +} + + +sub read_entity_body { + my $self = shift; + my $buf_ref = \$_[0]; + my $size = $_[1]; + die "Offset not supported yet" if $_[2]; + + my $chunked; + my $bytes; + + if (${*$self}{'http_first_body'}) { + ${*$self}{'http_first_body'} = 0; + delete ${*$self}{'http_chunked'}; + delete ${*$self}{'http_bytes'}; + my $method = shift(@{${*$self}{'http_request_method'}}); + my $status = ${*$self}{'http_status'}; + if ($method eq "HEAD") { + # this response is always empty regardless of other headers + $bytes = 0; + } + elsif (my $te = ${*$self}{'http_te'}) { + my @te = split(/\s*,\s*/, lc($te)); + die "Chunked must be last Transfer-Encoding '$te'" + unless pop(@te) eq "chunked"; + pop(@te) while @te && $te[-1] eq "chunked"; # ignore repeated chunked spec + + for (@te) { + if ($_ eq "deflate" && inflate_ok()) { + #require Compress::Raw::Zlib; + my ($i, $status) = Compress::Raw::Zlib::Inflate->new(); + die "Can't make inflator: $status" unless $i; + $_ = sub { my $out; $i->inflate($_[0], \$out); $out } + } + elsif ($_ eq "gzip" && gunzip_ok()) { + #require IO::Uncompress::Gunzip; + my @buf; + $_ = sub { + push(@buf, $_[0]); + return "" unless $_[1]; + my $input = join("", @buf); + my $output; + IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0) + or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError"; + return \$output; + }; + } + elsif ($_ eq "identity") { + $_ = sub { $_[0] }; + } + else { + die "Can't handle transfer encoding '$te'"; + } + } + + @te = reverse(@te); + + ${*$self}{'http_te2'} = @te ? \@te : ""; + $chunked = -1; + } + elsif (defined(my $content_length = ${*$self}{'http_content_length'})) { + $bytes = $content_length; + } + elsif ($status =~ /^(?:1|[23]04)/) { + # RFC 2616 says that these responses should always be empty + # but that does not appear to be true in practice [RT#17907] + $bytes = 0; + } + else { + # XXX Multi-Part types are self delimiting, but RFC 2616 says we + # only has to deal with 'multipart/byteranges' + + # Read until EOF + } + } + else { + $chunked = ${*$self}{'http_chunked'}; + $bytes = ${*$self}{'http_bytes'}; + } + + if (defined $chunked) { + # The state encoded in $chunked is: + # $chunked == 0: read CRLF after chunk, then chunk header + # $chunked == -1: read chunk header + # $chunked > 0: bytes left in current chunk to read + + if ($chunked <= 0) { + my $line = my_readline($self, 'Entity body'); + if ($chunked == 0) { + die "Missing newline after chunk data: '$line'" + if !defined($line) || $line ne ""; + $line = my_readline($self, 'Entity body'); + } + die "EOF when chunk header expected" unless defined($line); + my $chunk_len = $line; + $chunk_len =~ s/;.*//; # ignore potential chunk parameters + unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) { + die "Bad chunk-size in HTTP response: $line"; + } + $chunked = hex($1); + ${*$self}{'http_chunked'} = $chunked; + if ($chunked == 0) { + ${*$self}{'http_trailers'} = [$self->_read_header_lines]; + $$buf_ref = ""; + + my $n = 0; + if (my $transforms = delete ${*$self}{'http_te2'}) { + for (@$transforms) { + $$buf_ref = &$_($$buf_ref, 1); + } + $n = length($$buf_ref); + } + + # in case somebody tries to read more, make sure we continue + # to return EOF + delete ${*$self}{'http_chunked'}; + ${*$self}{'http_bytes'} = 0; + + return $n; + } + } + + my $n = $chunked; + $n = $size if $size && $size < $n; + $n = my_read($self, $$buf_ref, $n); + return undef unless defined $n; + + ${*$self}{'http_chunked'} = $chunked - $n; + + if ($n > 0) { + if (my $transforms = ${*$self}{'http_te2'}) { + for (@$transforms) { + $$buf_ref = &$_($$buf_ref, 0); + } + $n = length($$buf_ref); + $n = -1 if $n == 0; + } + } + return $n; + } + elsif (defined $bytes) { + unless ($bytes) { + $$buf_ref = ""; + return 0; + } + my $n = $bytes; + $n = $size if $size && $size < $n; + $n = my_read($self, $$buf_ref, $n); + ${*$self}{'http_bytes'} = defined $n ? $bytes - $n : $bytes; + return $n; + } + else { + # read until eof + $size ||= 8*1024; + return my_read($self, $$buf_ref, $size); + } +} + +sub get_trailers { + my $self = shift; + @{${*$self}{'http_trailers'} || []}; +} + +BEGIN { +my $gunzip_ok; +my $inflate_ok; + +sub gunzip_ok { + return $gunzip_ok if defined $gunzip_ok; + + # Try to load IO::Uncompress::Gunzip. + local $@; + local $SIG{__DIE__}; + $gunzip_ok = 0; + + eval { + require IO::Uncompress::Gunzip; + $gunzip_ok++; + }; + + return $gunzip_ok; +} + +sub inflate_ok { + return $inflate_ok if defined $inflate_ok; + + # Try to load Compress::Raw::Zlib. + local $@; + local $SIG{__DIE__}; + $inflate_ok = 0; + + eval { + require Compress::Raw::Zlib; + $inflate_ok++; + }; + + return $inflate_ok; +} + +} # BEGIN + +1; diff --git a/lib/Net/HTTP/NB.pm b/lib/Net/HTTP/NB.pm new file mode 100644 index 0000000..d908cf8 --- /dev/null +++ b/lib/Net/HTTP/NB.pm @@ -0,0 +1,110 @@ +package Net::HTTP::NB; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = "6.09"; +$VERSION = eval $VERSION; + +require Net::HTTP; +@ISA=qw(Net::HTTP); + +sub can_read { + return 1; +} + +sub sysread { + my $self = $_[0]; + if (${*$self}{'httpnb_read_count'}++) { + ${*$self}{'http_buf'} = ${*$self}{'httpnb_save'}; + die "Multi-read\n"; + } + my $buf; + my $offset = $_[3] || 0; + my $n = sysread($self, $_[1], $_[2], $offset); + ${*$self}{'httpnb_save'} .= substr($_[1], $offset); + return $n; +} + +sub read_response_headers { + my $self = shift; + ${*$self}{'httpnb_read_count'} = 0; + ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'}; + my @h = eval { $self->SUPER::read_response_headers(@_) }; + if ($@) { + return if $@ eq "Multi-read\n"; + die; + } + return @h; +} + +sub read_entity_body { + my $self = shift; + ${*$self}{'httpnb_read_count'} = 0; + ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'}; + # XXX I'm not so sure this does the correct thing in case of + # transfer-encoding transforms + my $n = eval { $self->SUPER::read_entity_body(@_); }; + if ($@) { + $_[0] = ""; + return -1; + } + return $n; +} + +1; + +__END__ + +=head1 NAME + +Net::HTTP::NB - Non-blocking HTTP client + +=head1 SYNOPSIS + + use Net::HTTP::NB; + my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@; + $s->write_request(GET => "/"); + + use IO::Select; + my $sel = IO::Select->new($s); + + READ_HEADER: { + die "Header timeout" unless $sel->can_read(10); + my($code, $mess, %h) = $s->read_response_headers; + redo READ_HEADER unless $code; + } + + while (1) { + die "Body timeout" unless $sel->can_read(10); + my $buf; + my $n = $s->read_entity_body($buf, 1024); + last unless $n; + print $buf; + } + +=head1 DESCRIPTION + +Same interface as C<Net::HTTP> but it will never try multiple reads +when the read_response_headers() or read_entity_body() methods are +invoked. This make it possible to multiplex multiple Net::HTTP::NB +using select without risk blocking. + +If read_response_headers() did not see enough data to complete the +headers an empty list is returned. + +If read_entity_body() did not see new entity data in its read +the value -1 is returned. + +=head1 SEE ALSO + +L<Net::HTTP> + +=head1 COPYRIGHT + +Copyright 2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/lib/Net/HTTPS.pm b/lib/Net/HTTPS.pm new file mode 100644 index 0000000..10c5c8a --- /dev/null +++ b/lib/Net/HTTPS.pm @@ -0,0 +1,111 @@ +package Net::HTTPS; + +use strict; +use vars qw($VERSION $SSL_SOCKET_CLASS @ISA); + +$VERSION = "6.09"; +$VERSION = eval $VERSION; + +# Figure out which SSL implementation to use +if ($SSL_SOCKET_CLASS) { + # somebody already set it +} +elsif ($SSL_SOCKET_CLASS = $ENV{PERL_NET_HTTPS_SSL_SOCKET_CLASS}) { + unless ($SSL_SOCKET_CLASS =~ /^(IO::Socket::SSL|Net::SSL)\z/) { + die "Bad socket class [$SSL_SOCKET_CLASS]"; + } + eval "require $SSL_SOCKET_CLASS"; + die $@ if $@; +} +elsif ($IO::Socket::SSL::VERSION) { + $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded +} +elsif ($Net::SSL::VERSION) { + $SSL_SOCKET_CLASS = "Net::SSL"; +} +else { + eval { require IO::Socket::SSL; }; + if ($@) { + my $old_errsv = $@; + eval { + require Net::SSL; # from Crypt-SSLeay + }; + if ($@) { + $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g; + die $old_errsv . $@; + } + $SSL_SOCKET_CLASS = "Net::SSL"; + } + else { + $SSL_SOCKET_CLASS = "IO::Socket::SSL"; + } +} + +require Net::HTTP::Methods; + +@ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods'); + +sub configure { + my($self, $cnf) = @_; + $self->http_configure($cnf); +} + +sub http_connect { + my($self, $cnf) = @_; + if ($self->isa("Net::SSL")) { + if ($cnf->{SSL_verify_mode}) { + if (my $f = $cnf->{SSL_ca_file}) { + $ENV{HTTPS_CA_FILE} = $f; + } + if (my $f = $cnf->{SSL_ca_path}) { + $ENV{HTTPS_CA_DIR} = $f; + } + } + if ($cnf->{SSL_verifycn_scheme}) { + $@ = "Net::SSL from Crypt-SSLeay can't verify hostnames; either install IO::Socket::SSL or turn off verification by setting the PERL_LWP_SSL_VERIFY_HOSTNAME environment variable to 0"; + return undef; + } + } + $self->SUPER::configure($cnf); +} + +sub http_default_port { + 443; +} + +if ($SSL_SOCKET_CLASS eq "Net::SSL") { + # The underlying SSLeay classes fails to work if the socket is + # placed in non-blocking mode. This override of the blocking + # method makes sure it stays the way it was created. + *blocking = sub { }; +} + +1; + +=head1 NAME + +Net::HTTPS - Low-level HTTP over SSL/TLS connection (client) + +=head1 DESCRIPTION + +The C<Net::HTTPS> is a low-level HTTP over SSL/TLS client. The interface is the same +as the interface for C<Net::HTTP>, but the constructor method take additional parameters +as accepted by L<IO::Socket::SSL>. The C<Net::HTTPS> object isa C<IO::Socket::SSL> +too, which make it inherit additional methods from that base class. + +For historical reasons this module also supports using C<Net::SSL> (from the +Crypt-SSLeay distribution) as its SSL driver and base class. This base is +automatically selected if available and C<IO::Socket::SSL> isn't. You might +also force which implementation to use by setting $Net::HTTPS::SSL_SOCKET_CLASS +before loading this module. If not set this variable is initialized from the +C<PERL_NET_HTTPS_SSL_SOCKET_CLASS> environment variable. + +=head1 ENVIRONMENT + +You might set the C<PERL_NET_HTTPS_SSL_SOCKET_CLASS> environment variable to the name +of the base SSL implementation (and Net::HTTPS base class) to use. The default +is C<IO::Socket::SSL>. Currently the only other supported value is C<Net::SSL>. + +=head1 SEE ALSO + +L<Net::HTTP>, L<IO::Socket::SSL> diff --git a/t/apache-https.t b/t/apache-https.t new file mode 100644 index 0000000..d7e54fd --- /dev/null +++ b/t/apache-https.t @@ -0,0 +1,73 @@ +#!perl -w + +BEGIN { + unless (-f "t/LIVE_TESTS" || -f "LIVE_TESTS") { + print "1..0 # SKIP Live tests disabled; pass --live-tests to Makefile.PL to enable\n"; + exit; + } + eval { + require IO::Socket::INET; + my $s = IO::Socket::INET->new( + PeerHost => "www.apache.org:443", + Timeout => 5, + ); + die "Can't connect: $@" unless $s; + }; + if ($@) { + print "1..0 # SKIP Can't connect to www.apache.org\n"; + print $@; + exit; + } + + unless (eval { require IO::Socket::SSL} || eval { require Net::SSL }) { + print "1..0 # SKIP IO::Socket::SSL or Net::SSL not available\n"; + print $@; + exit; + } +} + +use strict; +use Test; +plan tests => 8; + +use Net::HTTPS; + + +my $s = Net::HTTPS->new(Host => "www.apache.org", + KeepAlive => 1, + Timeout => 15, + PeerHTTPVersion => "1.1", + MaxLineLength => 512) || die "$@"; + +for (1..2) { + $s->write_request(TRACE => "/libwww-perl", + 'User-Agent' => 'Mozilla/5.0', + 'Accept-Language' => 'no,en', + Accept => '*/*'); + + my($code, $mess, %h) = $s->read_response_headers; + print "# ----------------------------\n"; + print "# $code $mess\n"; + for (sort keys %h) { + print "# $_: $h{$_}\n"; + } + print "#\n"; + + my $buf; + while (1) { + my $tmp; + my $n = $s->read_entity_body($tmp, 20); + last unless $n; + $buf .= $tmp; + } + $buf =~ s/\r//g; + (my $out = $buf) =~ s/^/# /gm; + print $out; + + ok($code, "200"); + ok($h{'Content-Type'}, "message/http"); + + ok($buf, qr/^TRACE \/libwww-perl HTTP\/1/); + ok($buf, qr/^User-Agent: Mozilla\/5.0$/m); +} + diff --git a/t/apache.t b/t/apache.t new file mode 100644 index 0000000..83f9faf --- /dev/null +++ b/t/apache.t @@ -0,0 +1,67 @@ +#!perl -w + +BEGIN { + unless (-f "t/LIVE_TESTS" || -f "LIVE_TESTS") { + print "1..0 # SKIP Live tests disabled; pass --live-tests to Makefile.PL to enable\n"; + exit; + } + eval { + require IO::Socket::INET; + my $s = IO::Socket::INET->new( + PeerHost => "www.apache.org:80", + Timeout => 5, + ); + die "Can't connect: $@" unless $s; + }; + if ($@) { + print "1..0 # SKIP Can't connect to www.apache.org\n"; + print $@; + exit; + } +} + +use strict; +use Test; +plan tests => 8; + +use Net::HTTP; + + +my $s = Net::HTTP->new(Host => "www.apache.org", + KeepAlive => 1, + Timeout => 15, + PeerHTTPVersion => "1.1", + MaxLineLength => 512) || die "$@"; + +for (1..2) { + $s->write_request(TRACE => "/libwww-perl", + 'User-Agent' => 'Mozilla/5.0', + 'Accept-Language' => 'no,en', + Accept => '*/*'); + + my($code, $mess, %h) = $s->read_response_headers; + print "# ----------------------------\n"; + print "# $code $mess\n"; + for (sort keys %h) { + print "# $_: $h{$_}\n"; + } + print "#\n"; + + my $buf; + while (1) { + my $tmp; + my $n = $s->read_entity_body($tmp, 20); + last unless $n; + $buf .= $tmp; + } + $buf =~ s/\r//g; + (my $out = $buf) =~ s/^/# /gm; + print $out; + + ok($code, "200"); + ok($h{'Content-Type'}, "message/http"); + + ok($buf, qr/^TRACE \/libwww-perl HTTP\/1/); + ok($buf, qr/^User-Agent: Mozilla\/5.0$/m); +} + diff --git a/t/http-nb.t b/t/http-nb.t new file mode 100644 index 0000000..d5c0341 --- /dev/null +++ b/t/http-nb.t @@ -0,0 +1,53 @@ +#!perl -w + +use strict; +use Test::More; +plan skip_all => "This test doesn't work on Windows" if $^O eq "MSWin32"; + +plan tests => 14; + +require Net::HTTP::NB; +use IO::Socket::INET; +use Data::Dumper; +use IO::Select; +use Socket qw(TCP_NODELAY); +my $buf; + +# bind a random TCP port for testing +my %lopts = ( + LocalAddr => "127.0.0.1", + LocalPort => 0, + Proto => "tcp", + ReuseAddr => 1, + Listen => 1024 +); + +my $srv = IO::Socket::INET->new(%lopts); +is(ref($srv), "IO::Socket::INET"); +my $host = $srv->sockhost . ':' . $srv->sockport; +my $nb = Net::HTTP::NB->new(Host => $host, Blocking => 0); +is(ref($nb), "Net::HTTP::NB"); +is(IO::Select->new($nb)->can_write(3), 1); + +ok($nb->write_request("GET", "/")); +my $acc = $srv->accept; +is(ref($acc), "IO::Socket::INET"); +$acc->sockopt(TCP_NODELAY, 1); +ok($acc->sysread($buf, 4096)); +ok($acc->syswrite("HTTP/1.1 200 OK\r\nContent-Length: 5\r\n\r\n")); + +is(1, IO::Select->new($nb)->can_read(3)); +my @r = $nb->read_response_headers; +is($r[0], 200); + +# calling read_entity_body before response body is readable causes +# EOF to never happen eventually +ok(!defined($nb->read_entity_body($buf, 4096)) && $!{EAGAIN}); + +is($acc->syswrite("hello"), 5, "server wrote response body"); + +is(IO::Select->new($nb)->can_read(3), 1, "client body is readable"); +is($nb->read_entity_body($buf, 4096), 5, "client gets 5 bytes"); + +# this fails if we got EAGAIN from the first read_entity_body call: +is($nb->read_entity_body($buf, 4096), 0, "client gets EOF"); diff --git a/t/http.t b/t/http.t new file mode 100644 index 0000000..cc2e1d3 --- /dev/null +++ b/t/http.t @@ -0,0 +1,209 @@ +#!perl -w + +use strict; +use Test; + +plan tests => 37; +#use Data::Dump (); + +my $CRLF = "\015\012"; +my $LF = "\012"; + +{ + package HTTP; + use vars qw(@ISA); + require Net::HTTP::Methods; + @ISA=qw(Net::HTTP::Methods); + + my %servers = ( + a => { "/" => "HTTP/1.0 200 OK${CRLF}Content-Type: text/plain${CRLF}Content-Length: 6${CRLF}${CRLF}Hello\n", + "/bad1" => "HTTP/1.0 200 OK${LF}Server: foo${LF}HTTP/1.0 200 OK${LF}Content-type: text/foo${LF}${LF}abc\n", + "/09" => "Hello${CRLF}World!${CRLF}", + "/chunked" => "HTTP/1.1 200 OK${CRLF}Transfer-Encoding: chunked${CRLF}${CRLF}0002; foo=3; bar${CRLF}He${CRLF}1${CRLF}l${CRLF}2${CRLF}lo${CRLF}0000${CRLF}Content-MD5: xxx${CRLF}${CRLF}", + "/chunked,chunked" => "HTTP/1.1 200 OK${CRLF}Transfer-Encoding: chunked${CRLF}Transfer-Encoding: chunked${CRLF}${CRLF}0002; foo=3; bar${CRLF}He${CRLF}1${CRLF}l${CRLF}2${CRLF}lo${CRLF}0000${CRLF}Content-MD5: xxx${CRLF}${CRLF}", + "/head" => "HTTP/1.1 200 OK${CRLF}Content-Length: 16${CRLF}Content-Type: text/plain${CRLF}${CRLF}", + "/colon-header" => "HTTP/1.1 200 OK${CRLF}Content-Type: text/plain${CRLF}Content-Length: 6${CRLF}Bad-Header: :foo${CRLF}${CRLF}Hello\n", + }, + ); + + sub http_connect { + my($self, $cnf) = @_; + my $server = $servers{$cnf->{PeerAddr}} || return undef; + ${*$self}{server} = $server; + ${*$self}{read_chunk_size} = $cnf->{ReadChunkSize}; + return $self; + } + + sub print { + my $self = shift; + #Data::Dump::dump("PRINT", @_); + my $in = shift; + my($method, $uri) = split(' ', $in); + + my $out; + if ($method eq "TRACE") { + my $len = length($in); + $out = "HTTP/1.0 200 OK${CRLF}Content-Length: $len${CRLF}" . + "Content-Type: message/http${CRLF}${CRLF}" . + $in; + } + else { + $out = ${*$self}{server}{$uri}; + $out = "HTTP/1.0 404 Not found${CRLF}${CRLF}" unless defined $out; + } + + ${*$self}{out} .= $out; + return 1; + } + + sub sysread { + my $self = shift; + #Data::Dump::dump("SYSREAD", @_); + my $length = $_[1]; + my $offset = $_[2] || 0; + + if (my $read_chunk_size = ${*$self}{read_chunk_size}) { + $length = $read_chunk_size if $read_chunk_size < $length; + } + + my $data = substr(${*$self}{out}, 0, $length, ""); + return 0 unless length($data); + + $_[0] = "" unless defined $_[0]; + substr($_[0], $offset) = $data; + return length($data); + } + + # ---------------- + + sub request { + my($self, $method, $uri, $headers, $opt) = @_; + $headers ||= []; + $opt ||= {}; + + my($code, $message, @h); + my $buf = ""; + eval { + $self->write_request($method, $uri, @$headers) || die "Can't write request"; + ($code, $message, @h) = $self->read_response_headers(%$opt); + + my $tmp; + my $n; + while ($n = $self->read_entity_body($tmp, 32)) { + #Data::Dump::dump($tmp, $n); + $buf .= $tmp; + } + + push(@h, $self->get_trailers); + + }; + + my %res = ( code => $code, + message => $message, + headers => \@h, + content => $buf, + ); + + if ($@) { + $res{error} = $@; + } + + return \%res; + } +} + +# Start testing +my $h; +my $res; + +$h = HTTP->new(Host => "a", KeepAlive => 1) || die; +$res = $h->request(GET => "/"); + +#Data::Dump::dump($res); + +ok($res->{code}, 200); +ok($res->{content}, "Hello\n"); + +$res = $h->request(GET => "/404"); +ok($res->{code}, 404); + +$res = $h->request(TRACE => "/foo"); +ok($res->{code}, 200); +ok($res->{content}, "TRACE /foo HTTP/1.1${CRLF}Keep-Alive: 300${CRLF}Connection: Keep-Alive${CRLF}Host: a${CRLF}${CRLF}"); + +# try to turn off keep alive +$h->keep_alive(0); +$res = $h->request(TRACE => "/foo"); +ok($res->{code}, "200"); +ok($res->{content}, "TRACE /foo HTTP/1.1${CRLF}Connection: close${CRLF}Host: a${CRLF}${CRLF}"); + +# try a bad one +# It's bad because 2nd 'HTTP/1.0 200' is illegal. But passes anyway if laxed => 1. +$res = $h->request(GET => "/bad1", [], {laxed => 1}); +ok($res->{code}, "200"); +ok($res->{message}, "OK"); +ok("@{$res->{headers}}", "Server foo Content-type text/foo"); +ok($res->{content}, "abc\n"); + +$res = $h->request(GET => "/bad1"); +ok($res->{error} =~ /Bad header/); +ok(!$res->{code}); +$h = undef; # it is in a bad state now + +$h = HTTP->new("a") || die; # reconnect +$res = $h->request(GET => "/09", [], {laxed => 1}); +ok($res->{code}, "200"); +ok($res->{message}, "Assumed OK"); +ok($res->{content}, "Hello${CRLF}World!${CRLF}"); +ok($h->peer_http_version, "0.9"); + +$res = $h->request(GET => "/09"); +ok($res->{error} =~ /^Bad response status line: 'Hello'/); +$h = undef; # it's in a bad state again + +$h = HTTP->new(Host => "a", KeepAlive => 1, ReadChunkSize => 1) || die; # reconnect +$res = $h->request(GET => "/chunked"); +ok($res->{code}, 200); +ok($res->{content}, "Hello"); +ok("@{$res->{headers}}", "Transfer-Encoding chunked Content-MD5 xxx"); + +# once more +$res = $h->request(GET => "/chunked"); +ok($res->{code}, "200"); +ok($res->{content}, "Hello"); +ok("@{$res->{headers}}", "Transfer-Encoding chunked Content-MD5 xxx"); + +# Test bogus headers. Chunked appearing twice is illegal, but happens anyway sometimes. [RT#77240] +$res = $h->request(GET => "/chunked,chunked"); +ok($res->{code}, "200"); +ok($res->{content}, "Hello"); +ok("@{$res->{headers}}", "Transfer-Encoding chunked Transfer-Encoding chunked Content-MD5 xxx"); + +# test head +$res = $h->request(HEAD => "/head"); +ok($res->{code}, "200"); +ok($res->{content}, ""); +ok("@{$res->{headers}}", "Content-Length 16 Content-Type text/plain"); + +$res = $h->request(GET => "/"); +ok($res->{code}, "200"); +ok($res->{content}, "Hello\n"); + +$h = HTTP->new(Host => undef, PeerAddr => "a", ); +$h->http_version("1.0"); +ok(!defined $h->host); +$res = $h->request(TRACE => "/"); +ok($res->{code}, "200"); +ok($res->{content}, "TRACE / HTTP/1.0\r\n\r\n"); + +# check that headers with colons at the start of values don't break +$res = $h->request(GET => '/colon-header'); +ok("@{$res->{headers}}", "Content-Type text/plain Content-Length 6 Bad-Header :foo"); + +require Net::HTTP; +eval { + $h = Net::HTTP->new; +}; +print "# $@"; +ok($@); + |