HTTP-Daemon-6.01HEADHTTP-Daemon-6.01master

12 files changed, 2184 insertions, 0 deletions

diff --git a/Changes b/Changes
new file mode 100644
index 0000000..bac19b2
--- /dev/null
+++ b/Changes
@@ -0,0 +1,18 @@
+_______________________________________________________________________________
+2012-02-18 HTTP-Daemon 6.01
+
+If you bind localhost, don't trust gethostbyaddr() to resolve the
+address.  [RT#67247]
+
+Restore perl-5.8.1 compatiblity.
+
+
+
+
+_______________________________________________________________________________
+2011-02-25 HTTP-Daemon 6.00
+
+Initial release of HTTP-Daemon as a separate distribution. There are no code
+changes besides incrementing the version number since libwww-perl-5.837.
+
+The HTTP::Daemon used to be bundled with the libwww-perl distribution.
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..0f76363
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,12 @@
+Changes
+lib/HTTP/Daemon.pm
+Makefile.PL
+MANIFEST			This list of files
+README
+t/chunked.t
+t/local/http.t
+t/misc/httpd
+t/misc/httpd_term.pl
+t/robot/ua-get.t
+t/robot/ua.t
+META.yml                                 Module meta-data (added by MakeMaker)
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..8f2eaf1
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,32 @@
+--- #YAML:1.0
+name:               HTTP-Daemon
+version:            6.01
+abstract:           a simple http server class
+author:
+    - Gisle Aas <gisle@activestate.com>
+license:            perl
+distribution_type:  module
+configure_requires:
+    ExtUtils::MakeMaker:  0
+build_requires:
+    ExtUtils::MakeMaker:  0
+requires:
+    HTTP::Date:       6
+    HTTP::Request:    6
+    HTTP::Response:   6
+    HTTP::Status:     6
+    IO::Socket:       0
+    LWP::MediaTypes:  6
+    perl:             5.008001
+    Sys::Hostname:    0
+resources:
+    MailingList:  mailto:libwww@perl.org
+    repository:   http://github.com/gisle/http-daemon
+no_index:
+    directory:
+        - t
+        - inc
+generated_by:       ExtUtils::MakeMaker version 6.57_05
+meta-spec:
+    url:      http://module-build.sourceforge.net/META-spec-v1.4.html
+    version:  1.4
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..09c7e86
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,52 @@
+#!perl -w
+
+require 5.008001;
+use strict;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME => 'HTTP::Daemon',
+    VERSION_FROM => 'lib/HTTP/Daemon.pm',
+    ABSTRACT_FROM => 'lib/HTTP/Daemon.pm',
+    AUTHOR => 'Gisle Aas <gisle@activestate.com>',
+    LICENSE => "perl",
+    MIN_PERL_VERSION => 5.008001,
+    PREREQ_PM => {
+	'Sys::Hostname' => 0,
+	'IO::Socket' => 0,
+	'HTTP::Request' => 6,
+	'HTTP::Response' => 6,
+	'HTTP::Status' => 6,
+	'HTTP::Date' => 6,
+	'LWP::MediaTypes' => 6,
+    },
+    META_MERGE => {
+	resources => {
+            repository => 'http://github.com/gisle/http-daemon',
+	    MailingList => 'mailto:libwww@perl.org',
+        }
+    },
+);
+
+
+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..be5a20a
--- /dev/null
+++ b/README
@@ -0,0 +1,237 @@
+NAME
+    HTTP::Daemon - a simple http server class
+
+SYNOPSIS
+      use HTTP::Daemon;
+      use HTTP::Status;
+
+      my $d = HTTP::Daemon->new || die;
+      print "Please contact me at: <URL:", $d->url, ">\n";
+      while (my $c = $d->accept) {
+          while (my $r = $c->get_request) {
+              if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
+                  # remember, this is *not* recommended practice :-)
+                  $c->send_file_response("/etc/passwd");
+              }
+              else {
+                  $c->send_error(RC_FORBIDDEN)
+              }
+          }
+          $c->close;
+          undef($c);
+      }
+
+DESCRIPTION
+    Instances of the `HTTP::Daemon' class are HTTP/1.1 servers that listen
+    on a socket for incoming requests. The `HTTP::Daemon' is a subclass of
+    `IO::Socket::INET', so you can perform socket operations directly on it
+    too.
+
+    The accept() method will return when a connection from a client is
+    available. The returned value will be an `HTTP::Daemon::ClientConn'
+    object which is another `IO::Socket::INET' subclass. Calling the
+    get_request() method on this object will read data from the client and
+    return an `HTTP::Request' object. The ClientConn object also provide
+    methods to send back various responses.
+
+    This HTTP daemon does not fork(2) for you. Your application, i.e. the
+    user of the `HTTP::Daemon' is responsible for forking if that is
+    desirable. Also note that the user is responsible for generating
+    responses that conform to the HTTP/1.1 protocol.
+
+    The following methods of `HTTP::Daemon' are new (or enhanced) relative
+    to the `IO::Socket::INET' base class:
+
+    $d = HTTP::Daemon->new
+    $d = HTTP::Daemon->new( %opts )
+        The constructor method takes the same arguments as the
+        `IO::Socket::INET' constructor, but unlike its base class it can
+        also be called without any arguments. The daemon will then set up a
+        listen queue of 5 connections and allocate some random port number.
+
+        A server that wants to bind to some specific address on the standard
+        HTTP port will be constructed like this:
+
+          $d = HTTP::Daemon->new(
+                   LocalAddr => 'www.thisplace.com',
+                   LocalPort => 80,
+               );
+
+        See IO::Socket::INET for a description of other arguments that can
+        be used configure the daemon during construction.
+
+    $c = $d->accept
+    $c = $d->accept( $pkg )
+    ($c, $peer_addr) = $d->accept
+        This method works the same the one provided by the base class, but
+        it returns an `HTTP::Daemon::ClientConn' reference by default. If a
+        package name is provided as argument, then the returned object will
+        be blessed into the given class. It is probably a good idea to make
+        that class a subclass of `HTTP::Daemon::ClientConn'.
+
+        The accept method will return `undef' if timeouts have been enabled
+        and no connection is made within the given time. The timeout()
+        method is described in IO::Socket.
+
+        In list context both the client object and the peer address will be
+        returned; see the description of the accept method IO::Socket for
+        details.
+
+    $d->url
+        Returns a URL string that can be used to access the server root.
+
+    $d->product_tokens
+        Returns the name that this server will use to identify itself. This
+        is the string that is sent with the `Server' response header. The
+        main reason to have this method is that subclasses can override it
+        if they want to use another product name.
+
+        The default is the string "libwww-perl-daemon/#.##" where "#.##" is
+        replaced with the version number of this module.
+
+    The `HTTP::Daemon::ClientConn' is a `IO::Socket::INET' subclass.
+    Instances of this class are returned by the accept() method of
+    `HTTP::Daemon'. The following methods are provided:
+
+    $c->get_request
+    $c->get_request( $headers_only )
+        This method reads data from the client and turns it into an
+        `HTTP::Request' object which is returned. It returns `undef' if
+        reading fails. If it fails, then the `HTTP::Daemon::ClientConn'
+        object ($c) should be discarded, and you should not try call this
+        method again on it. The $c->reason method might give you some
+        information about why $c->get_request failed.
+
+        The get_request() method will normally not return until the whole
+        request has been received from the client. This might not be what
+        you want if the request is an upload of a large file (and with
+        chunked transfer encoding HTTP can even support infinite request
+        messages - uploading live audio for instance). If you pass a TRUE
+        value as the $headers_only argument, then get_request() will return
+        immediately after parsing the request headers and you are
+        responsible for reading the rest of the request content. If you are
+        going to call $c->get_request again on the same connection you
+        better read the correct number of bytes.
+
+    $c->read_buffer
+    $c->read_buffer( $new_value )
+        Bytes read by $c->get_request, but not used are placed in the *read
+        buffer*. The next time $c->get_request is called it will consume the
+        bytes in this buffer before reading more data from the network
+        connection itself. The read buffer is invalid after $c->get_request
+        has failed.
+
+        If you handle the reading of the request content yourself you need
+        to empty this buffer before you read more and you need to place
+        unconsumed bytes here. You also need this buffer if you implement
+        services like *101 Switching Protocols*.
+
+        This method always returns the old buffer content and can optionally
+        replace the buffer content if you pass it an argument.
+
+    $c->reason
+        When $c->get_request returns `undef' you can obtain a short string
+        describing why it happened by calling $c->reason.
+
+    $c->proto_ge( $proto )
+        Return TRUE if the client announced a protocol with version number
+        greater or equal to the given argument. The $proto argument can be a
+        string like "HTTP/1.1" or just "1.1".
+
+    $c->antique_client
+        Return TRUE if the client speaks the HTTP/0.9 protocol. No status
+        code and no headers should be returned to such a client. This should
+        be the same as !$c->proto_ge("HTTP/1.0").
+
+    $c->head_request
+        Return TRUE if the last request was a `HEAD' request. No content
+        body must be generated for these requests.
+
+    $c->force_last_request
+        Make sure that $c->get_request will not try to read more requests
+        off this connection. If you generate a response that is not self
+        delimiting, then you should signal this fact by calling this method.
+
+        This attribute is turned on automatically if the client announces
+        protocol HTTP/1.0 or worse and does not include a "Connection:
+        Keep-Alive" header. It is also turned on automatically when HTTP/1.1
+        or better clients send the "Connection: close" request header.
+
+    $c->send_status_line
+    $c->send_status_line( $code )
+    $c->send_status_line( $code, $mess )
+    $c->send_status_line( $code, $mess, $proto )
+        Send the status line back to the client. If $code is omitted 200 is
+        assumed. If $mess is omitted, then a message corresponding to $code
+        is inserted. If $proto is missing the content of the
+        $HTTP::Daemon::PROTO variable is used.
+
+    $c->send_crlf
+        Send the CRLF sequence to the client.
+
+    $c->send_basic_header
+    $c->send_basic_header( $code )
+    $c->send_basic_header( $code, $mess )
+    $c->send_basic_header( $code, $mess, $proto )
+        Send the status line and the "Date:" and "Server:" headers back to
+        the client. This header is assumed to be continued and does not end
+        with an empty CRLF line.
+
+        See the description of send_status_line() for the description of the
+        accepted arguments.
+
+    $c->send_header( $field, $value )
+    $c->send_header( $field1, $value1, $field2, $value2, ... )
+        Send one or more header lines.
+
+    $c->send_response( $res )
+        Write a `HTTP::Response' object to the client as a response. We try
+        hard to make sure that the response is self delimiting so that the
+        connection can stay persistent for further request/response
+        exchanges.
+
+        The content attribute of the `HTTP::Response' object can be a normal
+        string or a subroutine reference. If it is a subroutine, then
+        whatever this callback routine returns is written back to the client
+        as the response content. The routine will be called until it return
+        an undefined or empty value. If the client is HTTP/1.1 aware then we
+        will use chunked transfer encoding for the response.
+
+    $c->send_redirect( $loc )
+    $c->send_redirect( $loc, $code )
+    $c->send_redirect( $loc, $code, $entity_body )
+        Send a redirect response back to the client. The location ($loc) can
+        be an absolute or relative URL. The $code must be one the redirect
+        status codes, and defaults to "301 Moved Permanently"
+
+    $c->send_error
+    $c->send_error( $code )
+    $c->send_error( $code, $error_message )
+        Send an error response back to the client. If the $code is missing a
+        "Bad Request" error is reported. The $error_message is a string that
+        is incorporated in the body of the HTML entity body.
+
+    $c->send_file_response( $filename )
+        Send back a response with the specified $filename as content. If the
+        file is a directory we try to generate an HTML index of it.
+
+    $c->send_file( $filename )
+    $c->send_file( $fd )
+        Copy the file to the client. The file can be a string (which will be
+        interpreted as a filename) or a reference to an `IO::Handle' or
+        glob.
+
+    $c->daemon
+        Return a reference to the corresponding `HTTP::Daemon' object.
+
+SEE ALSO
+    RFC 2616
+
+    IO::Socket::INET, IO::Socket
+
+COPYRIGHT
+    Copyright 1996-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/HTTP/Daemon.pm b/lib/HTTP/Daemon.pm
new file mode 100644
index 0000000..27a7bf4
--- /dev/null
+++ b/lib/HTTP/Daemon.pm
@@ -0,0 +1,906 @@
+package HTTP::Daemon;
+
+use strict;
+use vars qw($VERSION @ISA $PROTO $DEBUG);
+
+$VERSION = "6.01";
+
+use IO::Socket qw(AF_INET INADDR_ANY INADDR_LOOPBACK inet_ntoa);
+@ISA=qw(IO::Socket::INET);
+
+$PROTO = "HTTP/1.1";
+
+
+sub new
+{
+    my($class, %args) = @_;
+    $args{Listen} ||= 5;
+    $args{Proto}  ||= 'tcp';
+    return $class->SUPER::new(%args);
+}
+
+
+sub accept
+{
+    my $self = shift;
+    my $pkg = shift || "HTTP::Daemon::ClientConn";
+    my ($sock, $peer) = $self->SUPER::accept($pkg);
+    if ($sock) {
+        ${*$sock}{'httpd_daemon'} = $self;
+        return wantarray ? ($sock, $peer) : $sock;
+    }
+    else {
+        return;
+    }
+}
+
+
+sub url
+{
+    my $self = shift;
+    my $url = $self->_default_scheme . "://";
+    my $addr = $self->sockaddr;
+    if (!$addr || $addr eq INADDR_ANY) {
+ 	require Sys::Hostname;
+ 	$url .= lc Sys::Hostname::hostname();
+    }
+    elsif ($addr eq INADDR_LOOPBACK) {
+	$url .= inet_ntoa($addr);
+    }
+    else {
+	$url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
+    }
+    my $port = $self->sockport;
+    $url .= ":$port" if $port != $self->_default_port;
+    $url .= "/";
+    $url;
+}
+
+
+sub _default_port {
+    80;
+}
+
+
+sub _default_scheme {
+    "http";
+}
+
+
+sub product_tokens
+{
+    "libwww-perl-daemon/$HTTP::Daemon::VERSION";
+}
+
+
+
+package HTTP::Daemon::ClientConn;
+
+use vars qw(@ISA $DEBUG);
+use IO::Socket ();
+@ISA=qw(IO::Socket::INET);
+*DEBUG = \$HTTP::Daemon::DEBUG;
+
+use HTTP::Request  ();
+use HTTP::Response ();
+use HTTP::Status;
+use HTTP::Date qw(time2str);
+use LWP::MediaTypes qw(guess_media_type);
+use Carp ();
+
+my $CRLF = "\015\012";   # "\r\n" is not portable
+my $HTTP_1_0 = _http_version("HTTP/1.0");
+my $HTTP_1_1 = _http_version("HTTP/1.1");
+
+
+sub get_request
+{
+    my($self, $only_headers) = @_;
+    if (${*$self}{'httpd_nomore'}) {
+        $self->reason("No more requests from this connection");
+	return;
+    }
+
+    $self->reason("");
+    my $buf = ${*$self}{'httpd_rbuf'};
+    $buf = "" unless defined $buf;
+
+    my $timeout = $ {*$self}{'io_socket_timeout'};
+    my $fdset = "";
+    vec($fdset, $self->fileno, 1) = 1;
+    local($_);
+
+  READ_HEADER:
+    while (1) {
+	# loop until we have the whole header in $buf
+	$buf =~ s/^(?:\015?\012)+//;  # ignore leading blank lines
+	if ($buf =~ /\012/) {  # potential, has at least one line
+	    if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
+		if ($buf =~ /\015?\012\015?\012/) {
+		    last READ_HEADER;  # we have it
+		}
+		elsif (length($buf) > 16*1024) {
+		    $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
+		    $self->reason("Very long header");
+		    return;
+		}
+	    }
+	    else {
+		last READ_HEADER;  # HTTP/0.9 client
+	    }
+	}
+	elsif (length($buf) > 16*1024) {
+	    $self->send_error(414); # REQUEST_URI_TOO_LARGE
+	    $self->reason("Very long first line");
+	    return;
+	}
+	print STDERR "Need more data for complete header\n" if $DEBUG;
+	return unless $self->_need_more($buf, $timeout, $fdset);
+    }
+    if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
+	${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
+	$self->send_error(400);  # BAD_REQUEST
+	$self->reason("Bad request line: $buf");
+	return;
+    }
+    my $method = $1;
+    my $uri = $2;
+    my $proto = $3 || "HTTP/0.9";
+    $uri = "http://$uri" if $method eq "CONNECT";
+    $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
+    my $r = HTTP::Request->new($method, $uri);
+    $r->protocol($proto);
+    ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
+    ${*$self}{'httpd_head'} = ($method eq "HEAD");
+
+    if ($proto >= $HTTP_1_0) {
+	# we expect to find some headers
+	my($key, $val);
+      HEADER:
+	while ($buf =~ s/^([^\012]*)\012//) {
+	    $_ = $1;
+	    s/\015$//;
+	    if (/^([^:\s]+)\s*:\s*(.*)/) {
+		$r->push_header($key, $val) if $key;
+		($key, $val) = ($1, $2);
+	    }
+	    elsif (/^\s+(.*)/) {
+		$val .= " $1";
+	    }
+	    else {
+		last HEADER;
+	    }
+	}
+	$r->push_header($key, $val) if $key;
+    }
+
+    my $conn = $r->header('Connection');
+    if ($proto >= $HTTP_1_1) {
+	${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
+    }
+    else {
+	${*$self}{'httpd_nomore'}++ unless $conn &&
+                                           lc($conn) =~ /\bkeep-alive\b/;
+    }
+
+    if ($only_headers) {
+	${*$self}{'httpd_rbuf'} = $buf;
+        return $r;
+    }
+
+    # Find out how much content to read
+    my $te  = $r->header('Transfer-Encoding');
+    my $ct  = $r->header('Content-Type');
+    my $len = $r->header('Content-Length');
+
+    # Act on the Expect header, if it's there
+    for my $e ( $r->header('Expect') ) {
+        if( lc($e) eq '100-continue' ) {
+            $self->send_status_line(100);
+            $self->send_crlf;
+        }
+        else {
+            $self->send_error(417);
+            $self->reason("Unsupported Expect header value");
+            return;
+        }
+    }
+
+    if ($te && lc($te) eq 'chunked') {
+	# Handle chunked transfer encoding
+	my $body = "";
+      CHUNK:
+	while (1) {
+	    print STDERR "Chunked\n" if $DEBUG;
+	    if ($buf =~ s/^([^\012]*)\012//) {
+		my $chunk_head = $1;
+		unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
+		    $self->send_error(400);
+		    $self->reason("Bad chunk header $chunk_head");
+		    return;
+		}
+		my $size = hex($1);
+		last CHUNK if $size == 0;
+
+		my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
+		# must read until we have a complete chunk
+		while ($missing > 0) {
+		    print STDERR "Need $missing more bytes\n" if $DEBUG;
+		    my $n = $self->_need_more($buf, $timeout, $fdset);
+		    return unless $n;
+		    $missing -= $n;
+		}
+		$body .= substr($buf, 0, $size);
+		substr($buf, 0, $size+2) = '';
+
+	    }
+	    else {
+		# need more data in order to have a complete chunk header
+		return unless $self->_need_more($buf, $timeout, $fdset);
+	    }
+	}
+	$r->content($body);
+
+	# pretend it was a normal entity body
+	$r->remove_header('Transfer-Encoding');
+	$r->header('Content-Length', length($body));
+
+	my($key, $val);
+      FOOTER:
+	while (1) {
+	    if ($buf !~ /\012/) {
+		# need at least one line to look at
+		return unless $self->_need_more($buf, $timeout, $fdset);
+	    }
+	    else {
+		$buf =~ s/^([^\012]*)\012//;
+		$_ = $1;
+		s/\015$//;
+		if (/^([\w\-]+)\s*:\s*(.*)/) {
+		    $r->push_header($key, $val) if $key;
+		    ($key, $val) = ($1, $2);
+		}
+		elsif (/^\s+(.*)/) {
+		    $val .= " $1";
+		}
+		elsif (!length) {
+		    last FOOTER;
+		}
+		else {
+		    $self->reason("Bad footer syntax");
+		    return;
+		}
+	    }
+	}
+	$r->push_header($key, $val) if $key;
+
+    }
+    elsif ($te) {
+	$self->send_error(501); 	# Unknown transfer encoding
+	$self->reason("Unknown transfer encoding '$te'");
+	return;
+
+    }
+    elsif ($len) {
+	# Plain body specified by "Content-Length"
+	my $missing = $len - length($buf);
+	while ($missing > 0) {
+	    print "Need $missing more bytes of content\n" if $DEBUG;
+	    my $n = $self->_need_more($buf, $timeout, $fdset);
+	    return unless $n;
+	    $missing -= $n;
+	}
+	if (length($buf) > $len) {
+	    $r->content(substr($buf,0,$len));
+	    substr($buf, 0, $len) = '';
+	}
+	else {
+	    $r->content($buf);
+	    $buf='';
+	}
+    }
+    elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) {
+	# Handle multipart content type
+	my $boundary = "$CRLF--$2--";
+	my $index;
+	while (1) {
+	    $index = index($buf, $boundary);
+	    last if $index >= 0;
+	    # end marker not yet found
+	    return unless $self->_need_more($buf, $timeout, $fdset);
+	}
+	$index += length($boundary);
+	$r->content(substr($buf, 0, $index));
+	substr($buf, 0, $index) = '';
+
+    }
+    ${*$self}{'httpd_rbuf'} = $buf;
+
+    $r;
+}
+
+
+sub _need_more
+{
+    my $self = shift;
+    #my($buf,$timeout,$fdset) = @_;
+    if ($_[1]) {
+	my($timeout, $fdset) = @_[1,2];
+	print STDERR "select(,,,$timeout)\n" if $DEBUG;
+	my $n = select($fdset,undef,undef,$timeout);
+	unless ($n) {
+	    $self->reason(defined($n) ? "Timeout" : "select: $!");
+	    return;
+	}
+    }
+    print STDERR "sysread()\n" if $DEBUG;
+    my $n = sysread($self, $_[0], 2048, length($_[0]));
+    $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
+    $n;
+}
+
+
+sub read_buffer
+{
+    my $self = shift;
+    my $old = ${*$self}{'httpd_rbuf'};
+    if (@_) {
+	${*$self}{'httpd_rbuf'} = shift;
+    }
+    $old;
+}
+
+
+sub reason
+{
+    my $self = shift;
+    my $old = ${*$self}{'httpd_reason'};
+    if (@_) {
+        ${*$self}{'httpd_reason'} = shift;
+    }
+    $old;
+}
+
+
+sub proto_ge
+{
+    my $self = shift;
+    ${*$self}{'httpd_client_proto'} >= _http_version(shift);
+}
+
+
+sub _http_version
+{
+    local($_) = shift;
+    return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
+    $1 * 1000 + $2;
+}
+
+
+sub antique_client
+{
+    my $self = shift;
+    ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
+}
+
+
+sub force_last_request
+{
+    my $self = shift;
+    ${*$self}{'httpd_nomore'}++;
+}
+
+sub head_request
+{
+    my $self = shift;
+    ${*$self}{'httpd_head'};
+}
+
+
+sub send_status_line
+{
+    my($self, $status, $message, $proto) = @_;
+    return if $self->antique_client;
+    $status  ||= RC_OK;
+    $message ||= status_message($status) || "";
+    $proto   ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
+    print $self "$proto $status $message$CRLF";
+}
+
+
+sub send_crlf
+{
+    my $self = shift;
+    print $self $CRLF;
+}
+
+
+sub send_basic_header
+{
+    my $self = shift;
+    return if $self->antique_client;
+    $self->send_status_line(@_);
+    print $self "Date: ", time2str(time), $CRLF;
+    my $product = $self->daemon->product_tokens;
+    print $self "Server: $product$CRLF" if $product;
+}
+
+
+sub send_header
+{
+    my $self = shift;
+    while (@_) {
+	my($k, $v) = splice(@_, 0, 2);
+	$v = "" unless defined($v);
+	print $self "$k: $v$CRLF";
+    }
+}
+
+
+sub send_response
+{
+    my $self = shift;
+    my $res = shift;
+    if (!ref $res) {
+	$res ||= RC_OK;
+	$res = HTTP::Response->new($res, @_);
+    }
+    my $content = $res->content;
+    my $chunked;
+    unless ($self->antique_client) {
+	my $code = $res->code;
+	$self->send_basic_header($code, $res->message, $res->protocol);
+	if ($code =~ /^(1\d\d|[23]04)$/) {
+	    # make sure content is empty
+	    $res->remove_header("Content-Length");
+	    $content = "";
+	}
+	elsif ($res->request && $res->request->method eq "HEAD") {
+	    # probably OK
+	}
+	elsif (ref($content) eq "CODE") {
+	    if ($self->proto_ge("HTTP/1.1")) {
+		$res->push_header("Transfer-Encoding" => "chunked");
+		$chunked++;
+	    }
+	    else {
+		$self->force_last_request;
+	    }
+	}
+	elsif (length($content)) {
+	    $res->header("Content-Length" => length($content));
+	}
+	else {
+	    $self->force_last_request;
+            $res->header('connection','close'); 
+	}
+	print $self $res->headers_as_string($CRLF);
+	print $self $CRLF;  # separates headers and content
+    }
+    if ($self->head_request) {
+	# no content
+    }
+    elsif (ref($content) eq "CODE") {
+	while (1) {
+	    my $chunk = &$content();
+	    last unless defined($chunk) && length($chunk);
+	    if ($chunked) {
+		printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
+	    }
+	    else {
+		print $self $chunk;
+	    }
+	}
+	print $self "0$CRLF$CRLF" if $chunked;  # no trailers either
+    }
+    elsif (length $content) {
+	print $self $content;
+    }
+}
+
+
+sub send_redirect
+{
+    my($self, $loc, $status, $content) = @_;
+    $status ||= RC_MOVED_PERMANENTLY;
+    Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
+    $self->send_basic_header($status);
+    my $base = $self->daemon->url;
+    $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
+    $loc = $loc->abs($base);
+    print $self "Location: $loc$CRLF";
+    if ($content) {
+	my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
+	print $self "Content-Type: $ct$CRLF";
+    }
+    print $self $CRLF;
+    print $self $content if $content && !$self->head_request;
+    $self->force_last_request;  # no use keeping the connection open
+}
+
+
+sub send_error
+{
+    my($self, $status, $error) = @_;
+    $status ||= RC_BAD_REQUEST;
+    Carp::croak("Status '$status' is not an error") unless is_error($status);
+    my $mess = status_message($status);
+    $error  ||= "";
+    $mess = <<EOT;
+<title>$status $mess</title>
+<h1>$status $mess</h1>
+$error
+EOT
+    unless ($self->antique_client) {
+        $self->send_basic_header($status);
+        print $self "Content-Type: text/html$CRLF";
+	print $self "Content-Length: " . length($mess) . $CRLF;
+        print $self $CRLF;
+    }
+    print $self $mess unless $self->head_request;
+    $status;
+}
+
+
+sub send_file_response
+{
+    my($self, $file) = @_;
+    if (-d $file) {
+	$self->send_dir($file);
+    }
+    elsif (-f _) {
+	# plain file
+	local(*F);
+	sysopen(F, $file, 0) or 
+	  return $self->send_error(RC_FORBIDDEN);
+	binmode(F);
+	my($ct,$ce) = guess_media_type($file);
+	my($size,$mtime) = (stat _)[7,9];
+	unless ($self->antique_client) {
+	    $self->send_basic_header;
+	    print $self "Content-Type: $ct$CRLF";
+	    print $self "Content-Encoding: $ce$CRLF" if $ce;
+	    print $self "Content-Length: $size$CRLF" if $size;
+	    print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
+	    print $self $CRLF;
+	}
+	$self->send_file(\*F) unless $self->head_request;
+	return RC_OK;
+    }
+    else {
+	$self->send_error(RC_NOT_FOUND);
+    }
+}
+
+
+sub send_dir
+{
+    my($self, $dir) = @_;
+    $self->send_error(RC_NOT_FOUND) unless -d $dir;
+    $self->send_error(RC_NOT_IMPLEMENTED);
+}
+
+
+sub send_file
+{
+    my($self, $file) = @_;
+    my $opened = 0;
+    local(*FILE);
+    if (!ref($file)) {
+	open(FILE, $file) || return undef;
+	binmode(FILE);
+	$file = \*FILE;
+	$opened++;
+    }
+    my $cnt = 0;
+    my $buf = "";
+    my $n;
+    while ($n = sysread($file, $buf, 8*1024)) {
+	last if !$n;
+	$cnt += $n;
+	print $self $buf;
+    }
+    close($file) if $opened;
+    $cnt;
+}
+
+
+sub daemon
+{
+    my $self = shift;
+    ${*$self}{'httpd_daemon'};
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Daemon - a simple http server class
+
+=head1 SYNOPSIS
+
+  use HTTP::Daemon;
+  use HTTP::Status;
+
+  my $d = HTTP::Daemon->new || die;
+  print "Please contact me at: <URL:", $d->url, ">\n";
+  while (my $c = $d->accept) {
+      while (my $r = $c->get_request) {
+	  if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
+              # remember, this is *not* recommended practice :-)
+	      $c->send_file_response("/etc/passwd");
+	  }
+	  else {
+	      $c->send_error(RC_FORBIDDEN)
+	  }
+      }
+      $c->close;
+      undef($c);
+  }
+
+=head1 DESCRIPTION
+
+Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
+listen on a socket for incoming requests. The C<HTTP::Daemon> is a
+subclass of C<IO::Socket::INET>, so you can perform socket operations
+directly on it too.
+
+The accept() method will return when a connection from a client is
+available.  The returned value will be an C<HTTP::Daemon::ClientConn>
+object which is another C<IO::Socket::INET> subclass.  Calling the
+get_request() method on this object will read data from the client and
+return an C<HTTP::Request> object.  The ClientConn object also provide
+methods to send back various responses.
+
+This HTTP daemon does not fork(2) for you.  Your application, i.e. the
+user of the C<HTTP::Daemon> is responsible for forking if that is
+desirable.  Also note that the user is responsible for generating
+responses that conform to the HTTP/1.1 protocol.
+
+The following methods of C<HTTP::Daemon> are new (or enhanced) relative
+to the C<IO::Socket::INET> base class:
+
+=over 4
+
+=item $d = HTTP::Daemon->new
+
+=item $d = HTTP::Daemon->new( %opts )
+
+The constructor method takes the same arguments as the
+C<IO::Socket::INET> constructor, but unlike its base class it can also
+be called without any arguments.  The daemon will then set up a listen
+queue of 5 connections and allocate some random port number.
+
+A server that wants to bind to some specific address on the standard
+HTTP port will be constructed like this:
+
+  $d = HTTP::Daemon->new(
+           LocalAddr => 'www.thisplace.com',
+           LocalPort => 80,
+       );
+
+See L<IO::Socket::INET> for a description of other arguments that can
+be used configure the daemon during construction.
+
+=item $c = $d->accept
+
+=item $c = $d->accept( $pkg )
+
+=item ($c, $peer_addr) = $d->accept
+
+This method works the same the one provided by the base class, but it
+returns an C<HTTP::Daemon::ClientConn> reference by default.  If a
+package name is provided as argument, then the returned object will be
+blessed into the given class.  It is probably a good idea to make that
+class a subclass of C<HTTP::Daemon::ClientConn>.
+
+The accept method will return C<undef> if timeouts have been enabled
+and no connection is made within the given time.  The timeout() method
+is described in L<IO::Socket>.
+
+In list context both the client object and the peer address will be
+returned; see the description of the accept method L<IO::Socket> for
+details.
+
+=item $d->url
+
+Returns a URL string that can be used to access the server root.
+
+=item $d->product_tokens
+
+Returns the name that this server will use to identify itself.  This
+is the string that is sent with the C<Server> response header.  The
+main reason to have this method is that subclasses can override it if
+they want to use another product name.
+
+The default is the string "libwww-perl-daemon/#.##" where "#.##" is
+replaced with the version number of this module.
+
+=back
+
+The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
+subclass. Instances of this class are returned by the accept() method
+of C<HTTP::Daemon>.  The following methods are provided:
+
+=over 4
+
+=item $c->get_request
+
+=item $c->get_request( $headers_only )
+
+This method reads data from the client and turns it into an
+C<HTTP::Request> object which is returned.  It returns C<undef>
+if reading fails.  If it fails, then the C<HTTP::Daemon::ClientConn>
+object ($c) should be discarded, and you should not try call this
+method again on it.  The $c->reason method might give you some
+information about why $c->get_request failed.
+
+The get_request() method will normally not return until the whole
+request has been received from the client.  This might not be what you
+want if the request is an upload of a large file (and with chunked
+transfer encoding HTTP can even support infinite request messages -
+uploading live audio for instance).  If you pass a TRUE value as the
+$headers_only argument, then get_request() will return immediately
+after parsing the request headers and you are responsible for reading
+the rest of the request content.  If you are going to call
+$c->get_request again on the same connection you better read the
+correct number of bytes.
+
+=item $c->read_buffer
+
+=item $c->read_buffer( $new_value )
+
+Bytes read by $c->get_request, but not used are placed in the I<read
+buffer>.  The next time $c->get_request is called it will consume the
+bytes in this buffer before reading more data from the network
+connection itself.  The read buffer is invalid after $c->get_request
+has failed.
+
+If you handle the reading of the request content yourself you need to
+empty this buffer before you read more and you need to place
+unconsumed bytes here.  You also need this buffer if you implement
+services like I<101 Switching Protocols>.
+
+This method always returns the old buffer content and can optionally
+replace the buffer content if you pass it an argument.
+
+=item $c->reason
+
+When $c->get_request returns C<undef> you can obtain a short string
+describing why it happened by calling $c->reason.
+
+=item $c->proto_ge( $proto )
+
+Return TRUE if the client announced a protocol with version number
+greater or equal to the given argument.  The $proto argument can be a
+string like "HTTP/1.1" or just "1.1".
+
+=item $c->antique_client
+
+Return TRUE if the client speaks the HTTP/0.9 protocol.  No status
+code and no headers should be returned to such a client.  This should
+be the same as !$c->proto_ge("HTTP/1.0").
+
+=item $c->head_request
+
+Return TRUE if the last request was a C<HEAD> request.  No content
+body must be generated for these requests.
+
+=item $c->force_last_request
+
+Make sure that $c->get_request will not try to read more requests off
+this connection.  If you generate a response that is not self
+delimiting, then you should signal this fact by calling this method.
+
+This attribute is turned on automatically if the client announces
+protocol HTTP/1.0 or worse and does not include a "Connection:
+Keep-Alive" header.  It is also turned on automatically when HTTP/1.1
+or better clients send the "Connection: close" request header.
+
+=item $c->send_status_line
+
+=item $c->send_status_line( $code )
+
+=item $c->send_status_line( $code, $mess )
+
+=item $c->send_status_line( $code, $mess, $proto )
+
+Send the status line back to the client.  If $code is omitted 200 is
+assumed.  If $mess is omitted, then a message corresponding to $code
+is inserted.  If $proto is missing the content of the
+$HTTP::Daemon::PROTO variable is used.
+
+=item $c->send_crlf
+
+Send the CRLF sequence to the client.
+
+=item $c->send_basic_header
+
+=item $c->send_basic_header( $code )
+
+=item $c->send_basic_header( $code, $mess )
+
+=item $c->send_basic_header( $code, $mess, $proto )
+
+Send the status line and the "Date:" and "Server:" headers back to
+the client.  This header is assumed to be continued and does not end
+with an empty CRLF line.
+
+See the description of send_status_line() for the description of the
+accepted arguments.
+
+=item $c->send_header( $field, $value )
+
+=item $c->send_header( $field1, $value1, $field2, $value2, ... )
+
+Send one or more header lines.
+
+=item $c->send_response( $res )
+
+Write a C<HTTP::Response> object to the
+client as a response.  We try hard to make sure that the response is
+self delimiting so that the connection can stay persistent for further
+request/response exchanges.
+
+The content attribute of the C<HTTP::Response> object can be a normal
+string or a subroutine reference.  If it is a subroutine, then
+whatever this callback routine returns is written back to the
+client as the response content.  The routine will be called until it
+return an undefined or empty value.  If the client is HTTP/1.1 aware
+then we will use chunked transfer encoding for the response.
+
+=item $c->send_redirect( $loc )
+
+=item $c->send_redirect( $loc, $code )
+
+=item $c->send_redirect( $loc, $code, $entity_body )
+
+Send a redirect response back to the client.  The location ($loc) can
+be an absolute or relative URL. The $code must be one the redirect
+status codes, and defaults to "301 Moved Permanently"
+
+=item $c->send_error
+
+=item $c->send_error( $code )
+
+=item $c->send_error( $code, $error_message )
+
+Send an error response back to the client.  If the $code is missing a
+"Bad Request" error is reported.  The $error_message is a string that
+is incorporated in the body of the HTML entity body.
+
+=item $c->send_file_response( $filename )
+
+Send back a response with the specified $filename as content.  If the
+file is a directory we try to generate an HTML index of it.
+
+=item $c->send_file( $filename )
+
+=item $c->send_file( $fd )
+
+Copy the file to the client.  The file can be a string (which
+will be interpreted as a filename) or a reference to an C<IO::Handle>
+or glob.
+
+=item $c->daemon
+
+Return a reference to the corresponding C<HTTP::Daemon> object.
+
+=back
+
+=head1 SEE ALSO
+
+RFC 2616
+
+L<IO::Socket::INET>, L<IO::Socket>
+
+=head1 COPYRIGHT
+
+Copyright 1996-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/t/chunked.t b/t/chunked.t
new file mode 100644
index 0000000..e11799f
--- /dev/null
+++ b/t/chunked.t
@@ -0,0 +1,184 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Config;
+use HTTP::Daemon;
+use Test::More;
+# use Time::HiRes qw(sleep);
+our $CRLF;
+use Socket qw($CRLF);
+
+our $LOGGING = 0;
+
+our @TESTS = (
+              {
+               expect => 629,
+               comment => "traditional, unchunked POST request",
+               raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+User-Agent: UNTRUSTED/1.0
+Content-Type: application/x-www-form-urlencoded
+Content-Length: 629
+Host: localhost
+
+JSR-205=0;font_small=15;png=1;jpg=1;alpha_channel=256;JSR-82=0;JSR-135=1;mot-wt=0;JSR-75-pim=0;pointer_motion_event=0;camera=1;free_memory=455472;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;color=65536;JSR-120=1;JSR-184=1;JSR-180=0;JSR-75-file=0;push_socket=0;pointer_event=0;nokia-ui=1;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;gif=1;midp=MIDP-1.0 MIDP-2.0;font_large=22;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;"
+              },
+              {
+               expect => 8,
+               comment => "chunked with illegal Content-Length header; tiny message",
+               raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+Host: localhost
+Content-Type: application/x-www-form-urlencoded
+Content-Length: 8
+Transfer-Encoding: chunked
+
+8
+icm.x=u2
+0
+
+",
+              },
+              {
+               expect => 868,
+               comment => "chunked with illegal Content-Length header; medium sized",
+               raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+Host:dev05
+Connection:close
+Content-Type:application/x-www-form-urlencoded
+Content-Length:868
+transfer-encoding:chunked
+
+364
+JSR-205=0;font_small=20;png=1;jpg=1;JSR-82=0;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;free_memory=733456;user_agent=xxxxxxxxx/xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=815080;cldc=CLDC-1.0;canvas_size_y=182;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=20;JSR-184=0;JSR-120=1;color=32768;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=22;NAVIGATION RIGHT=5;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=0;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;gif=1;KEY NUM 4=52;NAVIGATION UP=1;KEY NUM 3=51;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-2.0 VSCL-1.1.0;font_large=20;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=2;LEFT SOFT KEY=21;font_medium=20;fullscreen_canvas_size_y=204;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=6;java_locale=en-DE;
+0
+
+",
+              },
+              {
+               expect => 1104,
+               comment => "chunked correctly, size ~1k; base for the big next test",
+               raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+User-Agent: UNTRUSTED/1.0
+Content-Type: application/x-www-form-urlencoded
+Host: localhost:80
+Transfer-Encoding: chunked
+
+450
+JSR-205=0;font_small=15;png=1;jpg=1;jsr184_dithering=0;CLEAR/DELETE=-8;JSR-82=0;alpha_channel=32;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;BACK/RETURN=-11;camera=1;free_memory=456248;user_agent=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=-5;JSR-184=1;JSR-120=1;color=65536;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=-7;NAVIGATION RIGHT=-4;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=1;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;KEY NUM 4=52;gif=1;KEY NUM 3=51;NAVIGATION UP=-1;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-1.0 MIDP-2.0;font_large=22;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=-3;LEFT SOFT KEY=-6;jsr184_antialiasing=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=-2;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;
+0
+
+"
+              },
+              {
+               expect => 1104*1024,
+               comment => "chunked with many chunks",
+               raw => ("POST /cgi-bin/redir-TE.pl HTTP/1.1
+User-Agent: UNTRUSTED/1.0
+Content-Type: application/x-www-form-urlencoded
+Host: localhost:80
+Transfer-Encoding: chunked
+
+".("450
+JSR-205=0;font_small=15;png=1;jpg=1;jsr184_dithering=0;CLEAR/DELETE=-8;JSR-82=0;alpha_channel=32;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;BACK/RETURN=-11;camera=1;free_memory=456248;user_agent=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=-5;JSR-184=1;JSR-120=1;color=65536;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=-7;NAVIGATION RIGHT=-4;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=1;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;KEY NUM 4=52;gif=1;KEY NUM 3=51;NAVIGATION UP=-1;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-1.0 MIDP-2.0;font_large=22;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=-3;LEFT SOFT KEY=-6;jsr184_antialiasing=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=-2;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;
+"x1024)."0
+
+")
+              },
+             );
+
+
+my $can_fork = $Config{d_fork} ||
+  (($^O eq 'MSWin32' || $^O eq 'NetWare') and
+   $Config{useithreads} and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
+
+my $tests = @TESTS;
+my $tport = 8333;
+
+my $tsock = IO::Socket::INET->new(LocalAddr => '0.0.0.0',
+                                  LocalPort => $tport,
+                                  Listen    => 1,
+                                  ReuseAddr => 1);
+if (!$can_fork) {
+  plan skip_all => "This system cannot fork";
+}
+elsif (!$tsock) {
+  plan skip_all => "Cannot listen on 0.0.0.0:$tport";
+}
+else {
+  close $tsock;
+  plan tests => $tests;
+}
+
+sub mywarn ($) {
+  return unless $LOGGING;
+  my($mess) = @_;
+  open my $fh, ">>", "http-daemon.out"
+    or die $!;
+  my $ts = localtime;
+  print $fh "$ts: $mess\n";
+  close $fh or die $!;
+}
+
+
+my $pid;
+if ($pid = fork) {
+  sleep 4;
+  for my $t (0..$#TESTS) {
+    my $test = $TESTS[$t];
+    my $raw = $test->{raw};
+    $raw =~ s/\r?\n/$CRLF/mg;
+    if (0) {
+      open my $fh, "| socket localhost $tport" or die;
+      print $fh $test;
+    }
+    use IO::Socket::INET;
+    my $sock = IO::Socket::INET->new(
+                                     PeerAddr => "127.0.0.1",
+                                     PeerPort => $tport,
+                                    ) or die;
+    if (0) {
+      for my $pos (0..length($raw)-1) {
+        print $sock substr($raw,$pos,1);
+        sleep 0.001;
+      }
+    } else {
+      print $sock $raw;
+    }
+    local $/;
+    my $resp = <$sock>;
+    close $sock;
+    my($got) = $resp =~ /\r?\n\r?\n(\d+)/s;
+    is($got,
+       $test->{expect},
+       "[$test->{expect}] $test->{comment}",
+      );
+  }
+  wait;
+} else {
+  die "cannot fork: $!" unless defined $pid;
+  my $d = HTTP::Daemon->new(
+                            LocalAddr => '0.0.0.0',
+                            LocalPort => $tport,
+                            ReuseAddr => 1,
+                           ) or die;
+  mywarn "Starting new daemon as '$$'";
+  my $i;
+  LISTEN: while (my $c = $d->accept) {
+    my $r = $c->get_request;
+    mywarn sprintf "headers[%s] content[%s]", $r->headers->as_string, $r->content;
+    my $res = HTTP::Response->new(200,undef,undef,length($r->content).$CRLF);
+    $c->send_response($res);
+    $c->force_last_request; # we're just not mature enough
+    $c->close;
+    undef($c);
+    last if ++$i >= $tests;
+  }
+}
+
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 2
+# End:
diff --git a/t/local/http.t b/t/local/http.t
new file mode 100644
index 0000000..421e7a3
--- /dev/null
+++ b/t/local/http.t
@@ -0,0 +1,380 @@
+if ($^O eq "MacOS") {
+    print "1..0\n";
+    exit(0);
+}
+
+unless (-f "CAN_TALK_TO_OURSELF") {
+    print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n";
+    exit;
+}
+
+$| = 1; # autoflush
+
+require IO::Socket;  # make sure this work before we try to make a HTTP::Daemon
+
+# First we make ourself a daemon in another process
+my $D = shift || '';
+if ($D eq 'daemon') {
+
+    require HTTP::Daemon;
+
+    my $d = HTTP::Daemon->new(Timeout => 10);
+
+    print "Please to meet you at: <URL:", $d->url, ">\n";
+    open(STDOUT, $^O eq 'VMS'? ">nl: " : ">/dev/null");
+
+    while ($c = $d->accept) {
+	$r = $c->get_request;
+	if ($r) {
+	    my $p = ($r->uri->path_segments)[1];
+	    my $func = lc("httpd_" . $r->method . "_$p");
+	    if (defined &$func) {
+		&$func($c, $r);
+	    }
+	    else {
+		$c->send_error(404);
+	    }
+	}
+	$c = undef;  # close connection
+    }
+    print STDERR "HTTP Server terminated\n";
+    exit;
+}
+else {
+    use Config;
+    my $perl = $Config{'perlpath'};
+    $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
+    open(DAEMON, "$perl local/http.t daemon |") or die "Can't exec daemon: $!";
+}
+
+use Test;
+plan tests => 54;
+
+my $greeting = <DAEMON>;
+$greeting =~ /(<[^>]+>)/;
+
+require URI;
+my $base = URI->new($1);
+sub url {
+   my $u = URI->new(@_);
+   $u = $u->abs($_[1]) if @_ > 1;
+   $u->as_string;
+}
+
+print "Will access HTTP server at $base\n";
+
+require LWP::UserAgent;
+require HTTP::Request;
+$ua = new LWP::UserAgent;
+$ua->agent("Mozilla/0.01 " . $ua->agent);
+$ua->from('gisle@aas.no');
+
+#----------------------------------------------------------------
+print "Bad request...\n";
+$req = new HTTP::Request GET => url("/not_found", $base);
+$req->header(X_Foo => "Bar");
+$res = $ua->request($req);
+
+ok($res->is_error);
+ok($res->code, 404);
+ok($res->message, qr/not\s+found/i);
+# we also expect a few headers
+ok($res->server);
+ok($res->date);
+
+#----------------------------------------------------------------
+print "Simple echo...\n";
+sub httpd_get_echo
+{
+    my($c, $req) = @_;
+    $c->send_basic_header(200);
+    print $c "Content-Type: message/http\015\012";
+    $c->send_crlf;
+    print $c $req->as_string;
+}
+
+$req = new HTTP::Request GET => url("/echo/path_info?query", $base);
+$req->push_header(Accept => 'text/html');
+$req->push_header(Accept => 'text/plain; q=0.9');
+$req->push_header(Accept => 'image/*');
+$req->push_header(':foo_bar' => 1);
+$req->if_modified_since(time - 300);
+$req->header(Long_text => 'This is a very long header line
+which is broken between
+more than one line.');
+$req->header(X_Foo => "Bar");
+
+$res = $ua->request($req);
+#print $res->as_string;
+
+ok($res->is_success);
+ok($res->code, 200);
+ok($res->message, "OK");
+
+$_ = $res->content;
+@accept = /^Accept:\s*(.*)/mg;
+
+ok($_, qr/^From:\s*gisle\@aas\.no\n/m);
+ok($_, qr/^Host:/m);
+ok(@accept, 3);
+ok($_, qr/^Accept:\s*text\/html/m);
+ok($_, qr/^Accept:\s*text\/plain/m);
+ok($_, qr/^Accept:\s*image\/\*/m);
+ok($_, qr/^If-Modified-Since:\s*\w{3},\s+\d+/m);
+ok($_, qr/^Long-Text:\s*This.*broken between/m);
+ok($_, qr/^Foo-Bar:\s*1\n/m);
+ok($_, qr/^X-Foo:\s*Bar\n/m);
+ok($_, qr/^User-Agent:\s*Mozilla\/0.01/m);
+
+# Try it with the higher level 'get' interface
+$res = $ua->get(url("/echo/path_info?query", $base),
+    Accept => 'text/html',
+    Accept => 'text/plain; q=0.9',
+    Accept => 'image/*',
+    X_Foo => "Bar",
+);
+#$res->dump;
+ok($res->code, 200);
+ok($res->content, qr/^From: gisle\@aas.no$/m);
+
+#----------------------------------------------------------------
+print "Send file...\n";
+
+my $file = "test-$$.html";
+open(FILE, ">$file") or die "Can't create $file: $!";
+binmode FILE or die "Can't binmode $file: $!";
+print FILE <<EOT;
+<html><title>En prøve</title>
+<h1>Dette er en testfil</h1>
+Jeg vet ikke hvor stor fila behøver å være heller, men dette
+er sikkert nok i massevis.
+EOT
+close(FILE);
+
+sub httpd_get_file
+{
+    my($c, $r) = @_;
+    my %form = $r->uri->query_form;
+    my $file = $form{'name'};
+    $c->send_file_response($file);
+    unlink($file) if $file =~ /^test-/;
+}
+
+$req = new HTTP::Request GET => url("/file?name=$file", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+
+ok($res->is_success);
+ok($res->content_type, 'text/html');
+ok($res->content_length, 147);
+ok($res->title, 'En prøve');
+ok($res->content, qr/å være/);
+
+# A second try on the same file, should fail because we unlink it
+$res = $ua->request($req);
+#print $res->as_string;
+ok($res->is_error);
+ok($res->code, 404);   # not found
+		
+# Then try to list current directory
+$req = new HTTP::Request GET => url("/file?name=.", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+ok($res->code, 501);   # NYI
+
+
+#----------------------------------------------------------------
+print "Check redirect...\n";
+sub httpd_get_redirect
+{
+   my($c) = @_;
+   $c->send_redirect("/echo/redirect");
+}
+
+$req = new HTTP::Request GET => url("/redirect/foo", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+
+ok($res->is_success);
+ok($res->content, qr|/echo/redirect|);
+ok($res->previous->is_redirect);
+ok($res->previous->code, 301);
+
+# Let's test a redirect loop too
+sub httpd_get_redirect2 { shift->send_redirect("/redirect3/") }
+sub httpd_get_redirect3 { shift->send_redirect("/redirect2/") }
+
+$req->uri(url("/redirect2", $base));
+$ua->max_redirect(5);
+$res = $ua->request($req);
+#print $res->as_string;
+ok($res->is_redirect);
+ok($res->header("Client-Warning"), qr/loop detected/i);
+ok($res->redirects, 5);
+
+$ua->max_redirect(0);
+$res = $ua->request($req);
+ok($res->previous, undef);
+ok($res->redirects, 0);
+$ua->max_redirect(5);
+
+#----------------------------------------------------------------
+print "Check basic authorization...\n";
+sub httpd_get_basic
+{
+    my($c, $r) = @_;
+    #print STDERR $r->as_string;
+    my($u,$p) = $r->authorization_basic;
+    if (defined($u) && $u eq 'ok 12' && $p eq 'xyzzy') {
+        $c->send_basic_header(200);
+	print $c "Content-Type: text/plain";
+	$c->send_crlf;
+	$c->send_crlf;
+	$c->print("$u\n");
+    }
+    else {
+        $c->send_basic_header(401);
+	$c->print("WWW-Authenticate: Basic realm=\"libwww-perl\"\015\012");
+	$c->send_crlf;
+    }
+}
+
+{
+   package MyUA; @ISA=qw(LWP::UserAgent);
+   sub get_basic_credentials {
+      my($self, $realm, $uri, $proxy) = @_;
+      if ($realm eq "libwww-perl" && $uri->rel($base) eq "basic") {
+	  return ("ok 12", "xyzzy");
+      }
+      else {
+          return undef;
+      }
+   }
+}
+$req = new HTTP::Request GET => url("/basic", $base);
+$res = MyUA->new->request($req);
+#print $res->as_string;
+
+ok($res->is_success);
+#print $res->content;
+
+# Let's try with a $ua that does not pass out credentials
+$res = $ua->request($req);
+ok($res->code, 401);
+
+# Let's try to set credentials for this realm
+$ua->credentials($req->uri->host_port, "libwww-perl", "ok 12", "xyzzy");
+$res = $ua->request($req);
+ok($res->is_success);
+
+# Then illegal credentials
+$ua->credentials($req->uri->host_port, "libwww-perl", "user", "passwd");
+$res = $ua->request($req);
+ok($res->code, 401);
+
+
+#----------------------------------------------------------------
+print "Check proxy...\n";
+sub httpd_get_proxy
+{
+   my($c,$r) = @_;
+   if ($r->method eq "GET" and
+       $r->uri->scheme eq "ftp") {
+       $c->send_basic_header(200);
+       $c->send_crlf;
+   }
+   else {
+       $c->send_error;
+   }
+}
+
+$ua->proxy(ftp => $base);
+$req = new HTTP::Request GET => "ftp://ftp.perl.com/proxy";
+$res = $ua->request($req);
+#print $res->as_string;
+ok($res->is_success);
+
+#----------------------------------------------------------------
+print "Check POSTing...\n";
+sub httpd_post_echo
+{
+   my($c,$r) = @_;
+   $c->send_basic_header;
+   $c->print("Content-Type: text/plain");
+   $c->send_crlf;
+   $c->send_crlf;
+
+   # Do it the hard way to test the send_file
+   open(TMP, ">tmp$$") || die;
+   binmode(TMP);
+   print TMP $r->as_string;
+   close(TMP) || die;
+
+   $c->send_file("tmp$$");
+
+   unlink("tmp$$");
+}
+
+$req = new HTTP::Request POST => url("/echo/foo", $base);
+$req->content_type("application/x-www-form-urlencoded");
+$req->content("foo=bar&bar=test");
+$res = $ua->request($req);
+#print $res->as_string;
+
+$_ = $res->content;
+ok($res->is_success);
+ok($_, qr/^Content-Length:\s*16$/mi);
+ok($_, qr/^Content-Type:\s*application\/x-www-form-urlencoded$/mi);
+ok($_, qr/^foo=bar&bar=test$/m);
+
+$req = HTTP::Request->new(POST => url("/echo/foo", $base));
+$req->content_type("multipart/form-data");
+$req->add_part(HTTP::Message->new(["Content-Type" => "text/plain"], "Hi\n"));
+$req->add_part(HTTP::Message->new(["Content-Type" => "text/plain"], "there\n"));
+$res = $ua->request($req);
+#print $res->as_string;
+ok($res->is_success);
+ok($res->content =~ /^Content-Type: multipart\/form-data; boundary=/m);
+
+#----------------------------------------------------------------
+print "Check partial content response...\n";
+sub httpd_get_partial
+{
+   my($c) = @_;
+    $c->send_basic_header(206);
+    print $c "Content-Type: image/jpeg\015\012";
+    $c->send_crlf;
+    print $c "some fake JPEG content";
+
+}
+
+{
+    $req = HTTP::Request->new(  GET => url("/partial", $base) );
+    $res = $ua->request($req);
+    ok($res->is_success); # "a 206 response is considered successful"
+}
+{
+    $ua->max_size(3);
+    $req = HTTP::Request->new(  GET => url("/partial", $base) );
+    $res = $ua->request($req);
+    ok($res->is_success); # "a 206 response is considered successful"
+    # Put max_size back how we found it. 
+    $ua->max_size(undef);
+    ok($res->as_string, qr/Client-Aborted: max_size/); # Client-Aborted is returned when max_size is given
+}
+
+
+#----------------------------------------------------------------
+print "Terminating server...\n";
+sub httpd_get_quit
+{
+    my($c) = @_;
+    $c->send_error(503, "Bye, bye");
+    exit;  # terminate HTTP server
+}
+
+$req = new HTTP::Request GET => url("/quit", $base);
+$res = $ua->request($req);
+
+ok($res->code, 503);
+ok($res->content, qr/Bye, bye/);
diff --git a/t/misc/httpd b/t/misc/httpd
new file mode 100755
index 0000000..f17a2bf
--- /dev/null
+++ b/t/misc/httpd
@@ -0,0 +1,31 @@
+#!/local/perl/bin/perl -w
+
+use HTTP::Daemon ();
+
+my $s = new HTTP::Daemon;
+die "Can't create daemon: $!" unless $s;
+
+print $s->url, "\n";
+
+my $c = $s->accept;
+die "Can't accept" unless $c;
+
+$c->timeout(60);
+my $req = $c->get_request;
+
+die "No request" unless $req;
+
+my $abs = $req->uri->abs;
+
+print $req->as_string;
+
+$c->send_file_response("/etc");
+
+#$c->send_redirect("http://www.sn.no/aas", 301, "<title>Piss off</title>");
+
+#my $res = HTTP::Response->new(400, undef,
+#			      HTTP::Headers->new(Foo => 'bar'),
+#			      "Gisle\n"
+#			     );
+#$c->send_response($res);
+
diff --git a/t/misc/httpd_term.pl b/t/misc/httpd_term.pl
new file mode 100755
index 0000000..ce38c22
--- /dev/null
+++ b/t/misc/httpd_term.pl
@@ -0,0 +1,25 @@
+#!/local/perl/bin/perl
+
+use HTTP::Daemon;
+#$HTTP::Daemon::DEBUG++;
+
+my $d = HTTP::Daemon->new(Timeout => 60);
+print "Please contact me at: <URL:", $d->url, ">\n";
+
+while (my $c = $d->accept) {
+  CONNECTION:
+    while (my $r = $c->get_request) {
+	print $r->as_string;
+	$c->autoflush;
+      RESPONSE:
+        while (<STDIN>) {
+	    last RESPONSE if $_ eq ".\n";
+	    last CONNECTION if $_ eq "..\n";
+	    print $c $_;
+	}
+	print "\nEOF\n";
+    }
+    print "CLOSE: ", $c->reason, "\n";
+    $c->close;
+    $c = undef;
+}
diff --git a/t/robot/ua-get.t b/t/robot/ua-get.t
new file mode 100644
index 0000000..5c18afa
--- /dev/null
+++ b/t/robot/ua-get.t
@@ -0,0 +1,156 @@
+if($^O eq "MacOS") {
+    print "1..0\n";
+    exit(0);
+}
+
+unless (-f "CAN_TALK_TO_OURSELF") {
+    print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n";
+    exit;
+}
+
+$| = 1; # autoflush
+require IO::Socket;  # make sure this work before we try to make a HTTP::Daemon
+
+# First we make ourself a daemon in another process
+my $D = shift || '';
+if ($D eq 'daemon') {
+
+    require HTTP::Daemon;
+
+    my $d = new HTTP::Daemon Timeout => 10;
+
+    print "Please to meet you at: <URL:", $d->url, ">\n";
+    open(STDOUT, $^O eq 'MSWin32' ?  ">nul" : $^O eq 'VMS' ? ">NL:"  : ">/dev/null");
+
+    while ($c = $d->accept) {
+	$r = $c->get_request;
+	if ($r) {
+	    my $p = ($r->uri->path_segments)[1];
+	    $p =~ s/\W//g;
+	    my $func = lc("httpd_" . $r->method . "_$p");
+	    #print STDERR "Calling $func...\n";
+            if (defined &$func) {
+		&$func($c, $r);
+	    }
+	    else {
+		$c->send_error(404);
+	    }
+	}
+	$c = undef;  # close connection
+    }
+    print STDERR "HTTP Server terminated\n";
+    exit;
+}
+else {
+    use Config;
+    my $perl = $Config{'perlpath'};
+    $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
+    open(DAEMON , "$perl robot/ua.t daemon |") or die "Can't exec daemon: $!";
+}
+
+print "1..8\n";
+
+
+$greating = <DAEMON>;
+$greating =~ /(<[^>]+>)/;
+
+require URI;
+my $base = URI->new($1);
+sub url {
+   my $u = URI->new(@_);
+   $u = $u->abs($_[1]) if @_ > 1;
+   $u->as_string;
+}
+
+print "Will access HTTP server at $base\n";
+
+require LWP::RobotUA;
+require HTTP::Request;
+$ua = new LWP::RobotUA 'lwp-spider/0.1', 'gisle@aas.no';
+$ua->delay(0.05);  # rather quick robot
+
+#----------------------------------------------------------------
+sub httpd_get_robotstxt
+{
+   my($c,$r) = @_;
+   $c->send_basic_header;
+   $c->print("Content-Type: text/plain");
+   $c->send_crlf;
+   $c->send_crlf;
+   $c->print("User-Agent: *
+Disallow: /private
+
+");
+}
+
+sub httpd_get_someplace
+{
+   my($c,$r) = @_;
+   $c->send_basic_header;
+   $c->print("Content-Type: text/plain");
+   $c->send_crlf;
+   $c->send_crlf;
+   $c->print("Okidok\n");
+}
+
+$res = $ua->get( url("/someplace", $base) );
+#print $res->as_string;
+print "not " unless $res->is_success;
+print "ok 1\n";
+
+$res = $ua->get( url("/private/place", $base) );
+#print $res->as_string;
+print "not " unless $res->code == 403
+                and $res->message =~ /robots.txt/;
+print "ok 2\n";
+
+
+$res = $ua->get( url("/foo", $base) );
+#print $res->as_string;
+print "not " unless $res->code == 404;  # not found
+print "ok 3\n";
+
+# Let the robotua generate "Service unavailable/Retry After response";
+$ua->delay(1);
+$ua->use_sleep(0);
+
+$res = $ua->get( url("/foo", $base) );
+#print $res->as_string;
+print "not " unless $res->code == 503   # Unavailable
+                and $res->header("Retry-After");
+print "ok 4\n";
+
+#----------------------------------------------------------------
+print "Terminating server...\n";
+sub httpd_get_quit
+{
+    my($c) = @_;
+    $c->send_error(503, "Bye, bye");
+    exit;  # terminate HTTP server
+}
+
+$ua->delay(0);
+
+$res = $ua->get( url("/quit", $base) );
+
+print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/;
+print "ok 5\n";
+
+#---------------------------------------------------------------
+$ua->delay(1);
+
+# host_wait() should be around 60s now
+print "not " unless abs($ua->host_wait($base->host_port) - 60) < 5;
+print "ok 6\n";
+
+# Number of visits to this place should be 
+print "not " unless $ua->no_visits($base->host_port) == 4;
+print "ok 7\n";
+
+# RobotUA used to have problem with mailto URLs.
+$ENV{SENDMAIL} = "dummy";
+$res = $ua->get("mailto:gisle\@aas.no");
+#print $res->as_string;
+
+print "not " unless $res->code == 400 && $res->message eq "Library does not allow method GET for 'mailto:' URLs";
+print "ok 8\n";
diff --git a/t/robot/ua.t b/t/robot/ua.t
new file mode 100644
index 0000000..5f679ae
--- /dev/null
+++ b/t/robot/ua.t
@@ -0,0 +1,151 @@
+if($^O eq "MacOS") {
+    print "1..0\n";
+    exit(0);
+}
+
+unless (-f "CAN_TALK_TO_OURSELF") {
+    print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n";
+    exit;
+}
+
+$| = 1; # autoflush
+require IO::Socket;  # make sure this work before we try to make a HTTP::Daemon
+
+# First we make ourself a daemon in another process
+my $D = shift || '';
+if ($D eq 'daemon') {
+
+    require HTTP::Daemon;
+
+    my $d = new HTTP::Daemon Timeout => 10;
+
+    print "Please to meet you at: <URL:", $d->url, ">\n";
+    open(STDOUT, $^O eq 'MSWin32' ?  ">nul" : $^O eq 'VMS' ? ">NL:"  : ">/dev/null");
+
+    while ($c = $d->accept) {
+	$r = $c->get_request;
+	if ($r) {
+	    my $p = ($r->uri->path_segments)[1];
+	    $p =~ s/\W//g;
+	    my $func = lc("httpd_" . $r->method . "_$p");
+	    #print STDERR "Calling $func...\n";
+            if (defined &$func) {
+		&$func($c, $r);
+	    }
+	    else {
+		$c->send_error(404);
+	    }
+	}
+	$c = undef;  # close connection
+    }
+    print STDERR "HTTP Server terminated\n";
+    exit;
+}
+else {
+    use Config;
+    my $perl = $Config{'perlpath'};
+    $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
+    open(DAEMON , "$perl robot/ua.t daemon |") or die "Can't exec daemon: $!";
+}
+
+print "1..7\n";
+
+
+$greating = <DAEMON>;
+$greating =~ /(<[^>]+>)/;
+
+require URI;
+my $base = URI->new($1);
+sub url {
+   my $u = URI->new(@_);
+   $u = $u->abs($_[1]) if @_ > 1;
+   $u->as_string;
+}
+
+print "Will access HTTP server at $base\n";
+
+require LWP::RobotUA;
+require HTTP::Request;
+$ua = new LWP::RobotUA 'lwp-spider/0.1', 'gisle@aas.no';
+$ua->delay(0.05);  # rather quick robot
+
+#----------------------------------------------------------------
+sub httpd_get_robotstxt
+{
+   my($c,$r) = @_;
+   $c->send_basic_header;
+   $c->print("Content-Type: text/plain");
+   $c->send_crlf;
+   $c->send_crlf;
+   $c->print("User-Agent: *
+Disallow: /private
+
+");
+}
+
+sub httpd_get_someplace
+{
+   my($c,$r) = @_;
+   $c->send_basic_header;
+   $c->print("Content-Type: text/plain");
+   $c->send_crlf;
+   $c->send_crlf;
+   $c->print("Okidok\n");
+}
+
+$req = new HTTP::Request GET => url("/someplace", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+print "not " unless $res->is_success;
+print "ok 1\n";
+
+$req = new HTTP::Request GET => url("/private/place", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+print "not " unless $res->code == 403
+                and $res->message =~ /robots.txt/;
+print "ok 2\n";
+
+$req = new HTTP::Request GET => url("/foo", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+print "not " unless $res->code == 404;  # not found
+print "ok 3\n";
+
+# Let the robotua generate "Service unavailable/Retry After response";
+$ua->delay(1);
+$ua->use_sleep(0);
+$req = new HTTP::Request GET => url("/foo", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+print "not " unless $res->code == 503   # Unavailable
+                and $res->header("Retry-After");
+print "ok 4\n";
+
+#----------------------------------------------------------------
+print "Terminating server...\n";
+sub httpd_get_quit
+{
+    my($c) = @_;
+    $c->send_error(503, "Bye, bye");
+    exit;  # terminate HTTP server
+}
+
+$ua->delay(0);
+$req = new HTTP::Request GET => url("/quit", $base);
+$res = $ua->request($req);
+
+print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/;
+print "ok 5\n";
+
+#---------------------------------------------------------------
+$ua->delay(1);
+
+# host_wait() should be around 60s now
+print "not " unless abs($ua->host_wait($base->host_port) - 60) < 5;
+print "ok 6\n";
+
+# Number of visits to this place should be 
+print "not " unless $ua->no_visits($base->host_port) == 4;
+print "ok 7\n";
+