Net-HTTP-6.09HEADNet-HTTP-6.09master

4 files changed, 402 insertions, 0 deletions

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($@);
+