#!./perl -w print "1..14\n"; use strict; #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}", "/head" => "HTTP/1.1 200 OK${CRLF}Content-Length: 16${CRLF}Content-Type: text/plain${CRLF}${CRLF}", }, ); 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 peerport { return 80; } 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); print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello\n"; print "ok 1\n"; $res = $h->request(GET => "/404"); print "not " unless $res->{code} eq "404"; print "ok 2\n"; $res = $h->request(TRACE => "/foo"); print "not " unless $res->{code} eq "200" && $res->{content} eq "TRACE /foo HTTP/1.1${CRLF}Keep-Alive: 300${CRLF}Connection: Keep-Alive${CRLF}Host: a${CRLF}${CRLF}"; print "ok 3\n"; # try to turn off keep alive $h->keep_alive(0); $res = $h->request(TRACE => "/foo"); print "not " unless $res->{code} eq "200" && $res->{content} eq "TRACE /foo HTTP/1.1${CRLF}Connection: close${CRLF}Host: a${CRLF}${CRLF}"; print "ok 4\n"; # try a bad one $res = $h->request(GET => "/bad1", [], {laxed => 1}); print "not " unless $res->{code} eq "200" && $res->{message} eq "OK" && "@{$res->{headers}}" eq "Server foo Content-type text/foo" && $res->{content} eq "abc\n"; print "ok 5\n"; $res = $h->request(GET => "/bad1"); print "not " unless $res->{error} =~ /Bad header/ && !$res->{code}; print "ok 6\n"; $h = undef; # it is in a bad state now $h = HTTP->new(Host => "a") || die; # reconnect $res = $h->request(GET => "/09", [], {laxed => 1}); print "not " unless $res->{code} eq "200" && $res->{message} eq "Assumed OK" && $res->{content} eq "Hello${CRLF}World!${CRLF}" && $h->peer_http_version eq "0.9"; print "ok 7\n"; $res = $h->request(GET => "/09"); print "not " unless $res->{error} =~ /^Bad response status line: 'Hello'/; print "ok 8\n"; $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"); print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello" && "@{$res->{headers}}" eq "Transfer-Encoding chunked Content-MD5 xxx"; print "ok 9\n"; # once more $res = $h->request(GET => "/chunked"); print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello" && "@{$res->{headers}}" eq "Transfer-Encoding chunked Content-MD5 xxx"; print "ok 10\n"; # test head $res = $h->request(HEAD => "/head"); print "not " unless $res->{code} eq "200" && $res->{content} eq "" && "@{$res->{headers}}" eq "Content-Length 16 Content-Type text/plain"; print "ok 11\n"; $res = $h->request(GET => "/"); print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello\n"; print "ok 12\n"; #use Data::Dump; Data::Dump::dump($res); $h = HTTP->new(Host => undef, PeerAddr => "a", ); $h->http_version("1.0"); print "not " if defined $h->host; print "ok 13\n"; $res = $h->request(TRACE => "/"); print "not " unless $res->{code} eq "200" && $res->{content} eq "TRACE / HTTP/1.0\r\n\r\n"; print "ok 14\n";