From 8780c70ceb3019aa50e129cb62daa3bfaebd0e82 Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Wed, 20 May 2015 18:48:12 +0000 Subject: Net-HTTP-6.09 --- Changes | 107 ++++++++ MANIFEST | 15 ++ MANIFEST.SKIP | 71 ++++++ META.json | 64 +++++ META.yml | 36 +++ Makefile.PL | 78 ++++++ README | 217 ++++++++++++++++ lib/Net/HTTP.pm | 294 ++++++++++++++++++++++ lib/Net/HTTP/Methods.pm | 648 ++++++++++++++++++++++++++++++++++++++++++++++++ lib/Net/HTTP/NB.pm | 110 ++++++++ lib/Net/HTTPS.pm | 111 +++++++++ t/apache-https.t | 73 ++++++ t/apache.t | 67 +++++ t/http-nb.t | 53 ++++ t/http.t | 209 ++++++++++++++++ 15 files changed, 2153 insertions(+) create mode 100644 Changes create mode 100644 MANIFEST create mode 100644 MANIFEST.SKIP create mode 100644 META.json create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100644 lib/Net/HTTP.pm create mode 100644 lib/Net/HTTP/Methods.pm create mode 100644 lib/Net/HTTP/NB.pm create mode 100644 lib/Net/HTTPS.pm create mode 100644 t/apache-https.t create mode 100644 t/apache.t create mode 100644 t/http-nb.t create mode 100644 t/http.t diff --git a/Changes b/Changes new file mode 100644 index 0000000..1a90727 --- /dev/null +++ b/Changes @@ -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 " + ], + "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 ' +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 ', + 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); + }; +} diff --git a/README b/README new file mode 100644 index 0000000..6b5217d --- /dev/null +++ b/README @@ -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 class is a low-level HTTP client. An instance of the +C class represents a connection to an HTTP server. The +HTTP protocol is described in RFC 2616. The C class +supports C and C. + +C is a sub-class of one of C (IPv6+IPv4), +C (IPv6+IPv4), or C (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): + +=over + +=item $s = Net::HTTP->new( %options ) + +The C constructor method takes the same options as +C'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 option is also the default for C's +C. The C defaults to 80 if not provided. +The C specification can also be embedded in the C +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 option provided by C's constructor +method is not allowed. + +If unable to connect to the given HTTP server then the constructor +returns C and $@ contains the reason. After a successful +connect, a C object is returned. + +=item $s->host + +Get/set the default value of the C header to send. The $host +must not be set to an empty string (or C) for HTTP/1.1. + +=item $s->keep_alive + +Get/set the I 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 +and C 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 for +I, and C for I. + +=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 header, then a header is inserted with the value +of the C attribute. Headers like C and +C might also be added depending on the status of the +C attribute. + +If $content is given (and it is non-empty), then a C +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 header with a value of +C 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 of C 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 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) 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 and C. + +The C option will make read_response_headers() more forgiving +towards servers that have not learned how to speak HTTP properly. The +C option is a boolean flag, and is enabled by passing in a TRUE +value. The C option can be used to capture bad header lines +when C is enabled. The value should be an array reference. +Bad header lines will be pushed onto the array. + +The C 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 or C +limits are reached. If the C option is turned on and +C and C 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 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 with C<$!> as EINTR or EAGAIN (see L). 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 and C. + +=head1 SEE ALSO + +L, L, L + +=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 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 + +=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 is a low-level HTTP over SSL/TLS client. The interface is the same +as the interface for C, but the constructor method take additional parameters +as accepted by L. The C object isa C +too, which make it inherit additional methods from that base class. + +For historical reasons this module also supports using C (from the +Crypt-SSLeay distribution) as its SSL driver and base class. This base is +automatically selected if available and C 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 environment variable. + +=head1 ENVIRONMENT + +You might set the C environment variable to the name +of the base SSL implementation (and Net::HTTPS base class) to use. The default +is C. Currently the only other supported value is C. + +=head1 SEE ALSO + +L, L 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($@); + -- cgit v1.2.1