# $Id: Daemon.pm,v 2.23 1998/11/17 20:42:24 john Exp $
#
# Based on HTTP::Daemon by Gisle Aas. Initial rewrite for EventLoop by
# Jan-Pieter Cornet

use strict;

package LWP::Daemon;

use vars qw($VERSION @ISA $PROTO $DEBUG);

$VERSION = sprintf("%d.%02d", q$Revision: 2.23 $ =~ /(\d+)\.(\d+)/);

use IO::Socket ();
use LWP::MainLoop qw(mainloop);
@ISA=qw(IO::Socket::INET);

$PROTO = "HTTP/1.1";

sub new
{
    my($class, %args) = @_;
    if ( ! $args{ManagedBy} ) {
	require Carp;
	Carp::croak(__PACKAGE__ . " needs a ManagedBy argument");
    }
    $args{Listen} ||= 5;
    $args{Proto}  ||= 'tcp';
    my $self = $class->SUPER::new(%args);
    return undef unless $self;

    my $host = $args{LocalAddr};
    unless ($host) {
	require Sys::Hostname;
	$host = Sys::Hostname::hostname();
    }
    ${*$self}{'httpd_server_name'} = $host;
    ${*$self}{'httpd_mgr'} = $args{ManagedBy};
    ${*$self}{'child_timeout'} = $args{ChildTimeout};
    ${*$self}{'child_write_timeout'} = $args{ChildWriteTimeout};
    mainloop->readable($self);
    ${*$self}{'httpd_mgr'}->server_init($self, $self->url)
	if ${*$self}{'httpd_mgr'}->can('server_init');
    $self;
}

sub readable
{
    my $self = shift;
    my($incoming, $peeraddr) = $self->accept;
    return unless $incoming;
    ${*$self}{'httpd_mgr'}->incoming_connection($self, $incoming, $peeraddr)
	if ${*$self}{'httpd_mgr'}->can('incoming_connection');
    mainloop->readable($incoming);
}

sub accept
{
    my $self = shift;
    my $pkg = shift || "LWP::Daemon::ClientConn";
    my($sock, $peeraddr) = $self->SUPER::accept($pkg);
    ${*$sock}{'httpd_daemon'} = $self if $sock;
    ${*$sock}{'httpd_mgr'} = ${*$self}{'httpd_mgr'};
    ${*$sock}{'timeout'} = ${*$self}{'child_timeout'};
    ${*$sock}{'write_timeout'} = ${*$self}{'child_write_timeout'};
    mainloop->timeout($sock, ${*$self}{'child_timeout'})
	if ${*$self}{'child_timeout'};
    wantarray ? ($sock, $peeraddr) : $sock;
}

sub url
{
    my $self = shift;
    my $url = "http://";
    $url .= ${*$self}{'httpd_server_name'};
    my $port = $self->sockport;
    $url .= ":$port" if $port != 80;
    $url .= "/";
    $url;
}

sub product_tokens
{
    "libwww-perl-daemon/$LWP::Daemon::VERSION";
}


package LWP::Daemon::ClientConn;

use vars qw(@ISA $DEBUG);
use IO::Socket ();
@ISA=qw(IO::Socket::INET);
*DEBUG = \$LWP::Daemon::DEBUG;

use HTTP::Request  ();
use HTTP::Response ();
use HTTP::Status;
use HTTP::Date qw(time2str);
use URI::URL qw(url);
use LWP::MediaTypes qw(guess_media_type);
use LWP::MainLoop qw(mainloop);
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 readable
{
    my($self) = @_;

    ${*$self}{'httpd_reason'} = "";
    my $buf = ${*$self}{'httpd_rbuf'} || "";

    my $n = sysread($self, $buf, 2048, length $buf);
    if ( ! $n ) {
	$self->reason(defined($n) ? "Client closed" : "sysread: $!");
	shutdown $self, 2;
	close $self;
	mainloop->forget($self);
	return;
    }

    ${*$self}{'httpd_rbuf'} = $buf;
    $self->_data_available if length $buf;
}

sub _data_available
{
    my $self = shift;

    if (${*$self}{'httpd_nomore'}) {
        $self->reason("No more requests from this connection");
	return;
    }

    my $buf = ${*$self}{'httpd_rbuf'};

    # check if we have a whole header in $buf yet. Otherwise, do nothing.
    my $req = $self->_parse_hdrs($buf);
    ${*$self}{'httpd_rbuf'} = $buf;
    ${*$self}{'httpd_current_req'} = $req;

    return if ! defined $req; # incomplete headers or error

    if ( ${*$self}{'httpd_mgr'}->can('new_request_header') ) {
	# new_request_header can specify it'll handle it by itself
	return if ${*$self}{'httpd_mgr'}->new_request_header($self, $req);
    }

    # Find out how much content to read
    my $te  = $req->header('Transfer-Encoding');
    my $ct  = $req->header('Content-Type');
    my $len = $req->header('Content-Length');

    if ($te && lc($te) eq 'chunked') {
	bless $self, "LWP::Daemon::ClientConn::Chunked";
    }
    elsif ($te) {
	$self->send_error(501); 	# Unknown transfer encoding
	$self->reason("Unknown transfer encoding '$te'");
	return;
    }
    elsif ( $ct && lc($ct) =~ /^multipart/ ) {
	bless $self, "LWP::Daemon::ClientConn::Multipart";
    }
    elsif ($len) {
	bless $self, "LWP::Daemon::ClientConn::ContentLength";
	${*$self}{'httpd_content_length'} = $len;
    }
    else {
	# got a complete request
	$self->new_request($req);
    }

    ${*$self}{'httpd_rbuf'} = $buf;
    # process rest of data if any
    $self->_data_available if length $buf;
}

sub new_request {
    my($self, $req) = @_;

    ${*$self}{'httpd_mgr'}->new_request($self, $req);
}

sub _parse_hdrs
{
    my $self = shift;

    $_[0] =~ s/^(?:\015?\012)+//; # ignore leading blank lines
    if ( length($_[0]) > 16*1024 ) {
	# very long something
	my($num, $msg) = index($_[0], "\012") > 16*1024 ? 
	    (414, "Very long first line") : (413, "Very long header");
	$self->send_error($num); # REQUEST_ENTITY_TOO_LARGE
	$self->reason($msg);
	$self->eof;
	return;
    }

    return unless $_[0] =~ /\012/; # return unless at least one line
    return if ( $_[0] =~ m{^\w+[^\012]+HTTP/\d+\.\d+\015?\012} &&
		$_[0] !~ /\015?\012\015?\012/ ); # HTTP x.x and no blank line

    if ( $_[0] !~ s{^(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP/\d+\.\d+))?[^\012]*\012}{} )
    {
	$self->send_error(400);  # BAD_REQUEST
	$self->reason("Bad request line");
	return;
    }
    my $proto = $3 || "HTTP/0.9";
    my $r = HTTP::Request->new($1, url($2, $self->daemon->url));
    $r->protocol($proto);
    ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);

    local $_;
    if ($proto >= $HTTP_1_0) {
	# we expect to find some headers
	my($key, $val);
      HEADER:
	while ($_[0] =~ 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";
	    } else {
		last HEADER;
	    }
	}
	$r->push_header($key, $val) if $key;
    }

    my $conn = $r->header('Connection');
    if ($proto >= $HTTP_1_1) {
	$self->force_last_request if $conn && lc($conn) =~ /\bclose\b/;
    } else {
	$self->force_last_request unless $conn &&
                                           lc($conn) =~ /\bkeep-alive\b/;
    }

    $r;
}

sub inactive
{
    # socket has timed out, close it
    my $self = shift;
    $self->reason("Timeout");
    shutdown $self, 2;
    close($self);
    mainloop->forget($self);
}

=item $c->timeout([$new_value])

Always returns the old timeout value for the socket. Optionally sets a
new value.

=cut

sub timeout
{
    my $self = shift;
    my $old = ${*$self}{'timeout'};
    if ( @_ ) {
	${*$self}{'timeout'} = shift;
	# actually set timeout unless write_timeout is defined and we are
	# writing
	unless ( ${*$self}{'write_timeout'} &&
	    length(${*$self}{'httpd_wbuf'} || "") )
	{
	    mainloop->timeout($self, ${*$self}{'timeout'});
	}
    }
    $old;
}

=item $c->write_timeout([$new_value])

Get or set the write_timeout value.

=cut

sub write_timeout
{
    my $self = shift;
    my $old = ${*$self}{'write_timeout'};
    if ( @_ ) {
	${*$self}{'write_timeout'} = shift;
	# set write timeout if we're writing and write_timeout is set
	if ( ${*$self}{'write_timeout'} &&
	    length(${*$self}{'httpd_wbuf'} || "") )
	{
	    mainloop->timeout($self, ${*$self}{'write_timeout'});
	}
	# otherwise set regular timeout, if present
	elsif ( ${*$self}{'timeout'} ) {
	    mainloop->timeout($self, ${*$self}{'timeout'});
	}
    }
    $old;
}

#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;
#}

=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 returned an undefined value.

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 return the old buffer content and can optionally
update the buffer content if you pass it an argument.

=cut

sub read_buffer
{
    my $self = shift;
    my $old = ${*$self}{'httpd_rbuf'};
    if (@_) {
	${*$self}{'httpd_rbuf'} = shift;
    }
    $old;
}

=item $c->write_buffer([$new_value])

Bytes scheduled for output as soon as the socket becomes writable.

This method always return the old buffer content and can optionally
update the buffer content if you pass it an argument.

=cut

sub write_buffer
{
    my $self = shift;
    my $old = ${*$self}{'httpd_wbuf'};
    if (@_) {
	${*$self}{'httpd_wbuf'} = shift;
    }
    $old;
}

=item $c->reason

When things blow up you can obtain a short string
describing why it happened by calling $c->reason.

=cut

sub reason
{
    my $self = shift;
    my $old = ${*$self}{'httpd_reason'};
    if (@_) {
	my $reason = shift;
        ${*$self}{'httpd_reason'} = $reason;
	# send error to manager object
	${*$self}{'httpd_mgr'}->error($self, $reason)
	    if $reason && ${*$self}{'httpd_mgr'}->can('error');
    }
    $old;
}


=item $c->proto_ge($proto)

Returns 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".

=cut

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;
}

=item $c->antique_client

Returns 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").

=cut

sub antique_client
{
    my $self = shift;
    ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
}


=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 announce
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.

=cut

sub force_last_request
{
    my $self = shift;
    ${*$self}{'httpd_nomore'}++;
}

=item $c->print(...)

Just like a regular print, except it doesn't block writing, but instead
uses a select loop.

=cut

sub print
{
    my $self = shift;
    my $buf = join("", @_);
    return unless length $buf;
    ${*$self}{'httpd_wbuf'} ||= "";
    if ( !length ${*$self}{'httpd_wbuf'} ) {
	mainloop->writable($self);
	if ( defined ${*$self}{'write_timeout'} ) {
	    # install separate write timeout
	    mainloop->timeout($self, ${*$self}{'write_timeout'});
	}
    }
    ${*$self}{'httpd_wbuf'} .= $buf;
}

=item $c->eof

Sends EOF on this socket. Closes the socket after all data has been sent.

=cut

sub eof
{
    my $self = shift;

    ${*$self}{'httpd_eof'}++;
}

sub writable
{
    my $self = shift;
    my $buf = \${*$self}{'httpd_wbuf'};
    if ( ! length $$buf ) {
	# someone unexpectedly emptied the buffer for us
	mainloop->writable($self, undef);
	if ( defined ${*$self}{'write_timeout'} ) {
	    # reinstall previous timeout
	    mainloop->timeout($self, ${*$self}{'timeout'});
	}
	return;
    }
    # ignore SIGPIPE while writing
    local $SIG{PIPE} = 'IGNORE';
    print STDERR "syswrite($self, \"...", length $$buf, "...\", 4096)\n"
	if $DEBUG;
    my $n = syswrite($self, $$buf, 4096);
    print STDERR "syswrite($self) returned $n\n" if $DEBUG;
    if ( ! $n ) {
	$self->reason(defined($n) ? "syswrite returned 0" : "syswrite: $!");
	mainloop->writable($self, undef);
    }
    if ( $n == length $$buf ) {
	${*$self}{'httpd_wbuf'} = "";
	if ( ${*$self}{'httpd_eof'} ) {
	    # signal eof
	    shutdown $self, 1;
	    close($self);
	    mainloop->forget($self);
	}
	else {
	    # uninstall writable handler
	    mainloop->writable($self, undef);
	    if ( defined ${*$self}{'write_timeout'} ) {
		# reinstall previous timeout
		mainloop->timeout($self, ${*$self}{'timeout'});
	    }
	}
	return;
    }
    else {
	substr($$buf, 0, $n) = '';
    }
}

=item $c->send_status_line( [$code, [$mess, [$proto]]] )

Sends 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
$LWP::Daemon::PROTO variable is used.

=cut

sub send_status_line
{
    my($self, $status, $message, $proto) = @_;
    return if $self->antique_client;
    $status  ||= RC_OK;
    $message ||= status_message($status) || "";
    $proto   ||= $LWP::Daemon::PROTO || "HTTP/1.1";
    $self->print("$proto $status $message$CRLF");
}

=item $c->send_crlf

Send the CRLF sequence to the client.

=cut

sub send_crlf
{
    my $self = shift;
    $self->print($CRLF);
}

=item $c->send_basic_header( [$code, [$mess, [$proto]]] )

Sends 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.

=cut

sub send_basic_header
{
    my $self = shift;
    return if $self->antique_client;
    $self->send_status_line(@_);
    $self->print("Date: ", time2str(time), $CRLF);
    my $product = $self->daemon->product_tokens;
    $self->print("Server: $product$CRLF") if $product;
}

=item $c->send_response( [$res] )

Takes a I<HTTP::Response> object as parameter and write it back to the
client as the 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 I<HTTP::Response> object can be a normal
string or a subroutine reference.  If it is a subroutine, then
whatever this callback routine returns will be 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 the chunked transfer encoding for the response.

Note that the callback will be called very quickly, without sending
out any output. There is no implicit streaming (yet).

This automatically closes the connection if this was the last (or only)
request.

*** This interface will likely change ***

=cut

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") if ${*$self}{'httpd_nomore'};
	$self->print($res->headers_as_string($CRLF));
	$self->print($CRLF);  # separates headers and content
    }
    if (ref($content) eq "CODE") {
	while (1) {
	    my $chunk = &$content();
	    last unless defined($chunk) && length($chunk);
	    if ($chunked) {
		$self->print(
		    sprintf "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF);
	    } else {
		$self->print($chunk);
	    }
	}
	$self->print("0$CRLF$CRLF") if $chunked;  # no trailers either
    } elsif (length $content) {
	$self->print($content);
    }
    $self->eof if ${*$self}{'httpd_nomore'};
}

=item $c->send_response_headers( [$res] )

Takes a reponse object and writes out just the headers. You should
take care that appropriate headers like Content-Length, Transfer-Encoding
etc are already properly set before calling this.

Automatically adds a "Connection: close" header if force_last_request has
been called.

*** This interface will likely change ***

=cut

sub send_response_headers
{
    my $self = shift;
    unless ($self->antique_client) {
	my $res = shift;
	if (!ref $res) {
	    $res ||= RC_OK;
	    $res = HTTP::Response->new($res, @_);
	}
	my $code = $res->code;
	$self->send_basic_header($code, $res->message, $res->protocol);
	$res->header("Connection" => "close") if ${*$self}{'httpd_nomore'};
	$self->print($res->headers_as_string($CRLF));
	$self->print($CRLF);  # separates headers and content
    }
}

=item $c->send_redirect( $loc, [$code, [$entity_body]] )

Sends a redirect response back to the client.  The location ($loc) can
be an absolute or a relative URL. The $code must be one the redirect
status codes, and it defaults to "301 Moved Permanently"

=cut

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);
    $loc = url($loc, $self->daemon->url) unless ref($loc);
    $loc = $loc->abs;
    $self->print("Location: $loc$CRLF");
    if ($content) {
	my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
	$self->print("Content-Type: $ct$CRLF");
    }
    $self->print($CRLF);
    $self->print($content) if $content;
    $self->force_last_request;  # no use keeping the connection open
    $self->eof;
}


=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.

=cut

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);
        $self->print("Content-Type: text/html$CRLF");
	$self->print("Content-Length: ", length($mess), $CRLF);
        $self->print($CRLF);
    }
    $self->print($mess);
    $self->eof if ${*$self}{'httpd_nomore'};
    $status;
}


=item $c->send_file_response($filename)

Send back a response with the specified $filename as content.  If the
file happen to be a directory we will try to generate an HTML index
of it.

Note that this blocks while reading the file, stores the entire file
in the sendbuffer before writing it out.

=cut

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);
	my($ct,$ce) = guess_media_type($file);
	my($size,$mtime) = (stat _)[7,9];
	unless ($self->antique_client) {
	    $self->send_basic_header;
	    $self->print("Content-Type: $ct$CRLF");
	    $self->print("Content-Encoding: $ce$CRLF") if $ce;
	    $self->print("Content-Length: $size$CRLF") if $size;
	    $self->print("Last-Modified: ", time2str($mtime), "$CRLF")
		if $mtime;
	    $self->print($CRLF);
	}
	$self->send_file(\*F);
	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); # XXX
}


=item $c->send_file($fd);

Copies the file back to the client.  The file can be a string (which
will be interpreted as a filename) or a reference to an I<IO::Handle>
or glob.

=cut

sub send_file
{
    my($self, $file) = @_;
    my $opened = 0;
    if (!ref($file)) {
	local(*F);
	open(F, $file) || return undef;
	binmode(F);
	$file = \*F;
	$opened++;
    }
    my $cnt = 0;
    my $buf = "";
    my $n;
    while ($n = sysread($file, $buf, 8*1024)) {
	last if !$n;
	$cnt += $n;
	$self->print($buf);
    }
    close($file) if $opened;
    $self->eof if ${*$self}{'httpd_nomore'};
    $cnt;
}


=item $c->daemon

Return a reference to the corresponding I<LWP::Daemon> object.

=cut

sub daemon
{
    my $self = shift;
    ${*$self}{'httpd_daemon'};
}

=back

=head1 SEE ALSO

RFC 2068

L<IO::Socket>, L<Apache>

=head1 COPYRIGHT

Copyright 1996-1998, Gisle Aas

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

package LWP::Daemon::ClientConn::ContentLength;

use vars qw(@ISA);
@ISA = qw(LWP::Daemon::ClientConn);

# Process a plain body specified by "Content-Length"
sub _data_available
{
    my $self = shift;

    my $len = ${*$self}{'httpd_content_length'};
    my $buf = ${*$self}{'httpd_rbuf'};
    my $req = ${*$self}{'httpd_current_req'};
    
    my $missing = $len - length($buf);
    return if $missing > 0; # need more data
    if ( $missing == 0 ) {
	$req->content($buf);
	$buf = "";
    }
    else {
	$req->content(substr($buf,0,$len));
	substr($buf, 0, $len) = '';
    }
    ${*$self}{'httpd_rbuf'} = $buf;
    bless $self, "LWP::Daemon::ClientConn";
    $self->new_request($req);
    $self->_data_available if length $buf;
}

package LWP::Daemon::ClientConn::Multipart;

use vars qw(@ISA);
use HTTP::Status;
@ISA = qw(LWP::Daemon::ClientConn);

sub _data_available
{
# extract the boundary from the Content-Type
# lc($ct) =~ m{^multipart/\w+\s*;.*boundary\s*=\s*(\w+)}
    # XXX
    my $self = shift;
    $self->send_error(RC_NOT_IMPLEMENTED);
    $self->force_last_request;
    $self->eof;

	# Handle multipart content type
#	my $boundary = "$CRLF--$1--$CRLF";
#	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) = '';
}

package LWP::Deamon::ClientConn::Chunked;

use vars qw(@ISA);
use HTTP::Status;
@ISA = qw(LWP::Daemon::ClientConn);

sub _data_available
{
    # XXX
    my $self = shift;
    $self->send_error(RC_NOT_IMPLEMENTED);
    $self->force_last_request;
    $self->eof;

	# 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;
}

1;