[PATCH] testing-friendly HTTP::Daemon2, capable of HTTP-over-two-pipes

### net-http-pair-2010-09-16.pl --- Net::HTTP over an IO-pair  -*- Perl -*-

use strict;
use warnings;

require IO::Handle;
require Net::HTTP::Methods;

package XXX;

use strict;
use vars qw($VERSION @ISA);
use warnings;

@ISA = qw(Net::HTTP::Methods);
sub new {
    my ($class, $input, $output, @args) = @_;
    my $self
	= $class->SUPER::new ("Host" => "localhost", @args)
	or return undef;
    ${*$self}{"XXX.input"} = $input;
    ${*$self}{"XXX.output"} = $output;
    ## .
    return $self;
}

sub print {
    my $self = shift;
    ${*$self}{"XXX.output"}->print (@_);
}

sub sysread {
    my $self = shift;
    ${*$self}{"XXX.input"}->sysread (@_);
}

sub http_connect {
    1;
}

package main;

{
    my $o
	= \*STDOUT;
    $o->print ("Hello, world!\n");
}

my $f
    = new XXX (\*STDIN, \*STDOUT)
    or die ($!);

$f->print ("Hello, world!\n");

$f->http_configure ({ "Host" => "xxx:8080" });
$f->write_request ("GET", "http://xxx:8080/hello", my %h);
my @a = $f->read_response_headers ();

print (join (", ", @a), "\n");
### net-http-pair-2010-09-16.pl ends here

### http-daemon-pair-2010-09-16.pl --- HTTP::Daemon2 / IO-pair  -*- Perl -*-

use strict;
use warnings;

use HTTP::Status;
use IO::Handle;

require HTTP::Daemon2;

my $s = new HTTP::Daemon2 ();
my $c = $s->new_conn (\*STDIN, \*STDOUT);

## basically, a copy of the example in HTTP::Daemon(3pm)
while (my $r = $c->get_request) {
    if ($r->method eq "GET" and $r->uri->path eq "/xyzzy") {
	$c->send_file_response("/dev/null");
    } else {
	$c->send_error(RC_FORBIDDEN);
    }
}
$c->close;
print STDERR "XXX: ", $c->reason, "\n";

### http-daemon-pair-2010-09-16.pl ends here

### Daemon2.pm --- HTTP::Daemon over two IO handles  -*- Perl -*-

## This module is a hacked version of HTTP::Daemon, and thus inherits
## the license of the latter, which is as follows.

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

package HTTP::Daemon2;

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

require HTTP::Daemon;

$VERSION = "5.836";

@ISA = qw ();

$PROTO = "HTTP/1.1";


sub new
{
    my($class, %args) = @_;
    require Symbol;
    my $self
	= bless Symbol::gensym (), $class;
    return $self;
}


sub new_conn
{
    my $self = shift;
    my $input = shift;
    my $output = shift;
    my $pkg = shift || "HTTP::Daemon::ClientConn2";
    require Symbol;
    my $conn
	= bless Symbol::gensym (), $pkg;
    ${*$conn}{'httpd_daemon'} = $self;
    ${*$conn}{"ClientConn2.input"} = $input;
    ${*$conn}{"ClientConn2.output"} = $output;
    ## .
    return
	(wantarray ? ($conn, undef) : $conn);
}


sub url
{
    my $self = shift;
    my $url
	= ($self->_default_scheme
	   . "://localhost/");
    ## .
    $url;
}


sub _default_port {
    80;
}


sub _default_scheme {
    "http";
}


sub product_tokens
{
    "libwww-perl-daemon/$HTTP::Daemon2::VERSION";
}



package HTTP::Daemon::ClientConn2;

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

sub close
{
    my ($self) = @_;
    return
	unless ${*$self}{"ClientConn2.reallyClose"};
    ${*$self}{"ClientConn2.input"}->close ();
    ${*$self}{"ClientConn2.output"}->close ();
}

sub fdset
{
    my ($self) = @_;
    my $fdset = "";
    vec ($fdset, ${*$self}{"ClientConn2.input"}->fileno,  1) = 1;
    vec ($fdset, ${*$self}{"ClientConn2.output"}->fileno, 1) = 1;
    return $fdset;
}

sub print {
    # print STDERR ("print: ", join (", ", @_), "\n");
    my $self = shift;
    ${*$self}{"ClientConn2.output"}->print (@_);
}

sub sysread {
    # print STDERR ("sysread: ", join (", ", @_), "\n");
    my $self = shift;
    ${*$self}{"ClientConn2.input"}->sysread (@_);
}

### Daemon2.pm ends here

diff --git a/lib/HTTP/Daemon.pm b/lib/HTTP/Daemon.pm
index cf61147..271ee55 100644
--- a/lib/HTTP/Daemon.pm
+++ b/lib/HTTP/Daemon.pm
@@ -73,9 +73,25 @@ sub product_tokens
 
 package HTTP::Daemon::ClientConn;
 
-use vars qw(@ISA $DEBUG);
+use vars qw(@ISA);
 use IO::Socket ();
-@ISA=qw(IO::Socket::INET);
+@ISA=qw(IO::Socket::INET HTTP::Daemon::ClientConn::Methods);
+
+
+sub fdset
+{
+    my ($self) = @_;
+    my $fdset = "";
+    vec ($fdset, $self->fileno, 1) = 1;
+    return $fdset;
+}
+
+
+
+package HTTP::Daemon::ClientConn::Methods;
+
+use vars qw(@ISA $DEBUG);
+@ISA = ();
 *DEBUG = \$HTTP::Daemon::DEBUG;
 
 use HTTP::Request  ();
@@ -103,8 +119,8 @@ sub get_request
     $buf = "" unless defined $buf;
 
     my $timeout = $ {*$self}{'io_socket_timeout'};
-    my $fdset = "";
-    vec($fdset, $self->fileno, 1) = 1;
+    my $fdset
+        = $self->fdset ();
     local($_);
 
   READ_HEADER:
@@ -331,7 +347,7 @@ sub _need_more
 	}
     }
     print STDERR "sysread()\n" if $DEBUG;
-    my $n = sysread($self, $_[0], 2048, length($_[0]));
+    my $n = $self->sysread ($_[0], 2048, length($_[0]));
     $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
     $n;
 }
@@ -401,14 +417,14 @@ sub send_status_line
     $status  ||= RC_OK;
     $message ||= status_message($status) || "";
     $proto   ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
-    print $self "$proto $status $message$CRLF";
+    $self->print ("$proto $status $message$CRLF");
 }
 
 
 sub send_crlf
 {
     my $self = shift;
-    print $self $CRLF;
+    $self->print ($CRLF);
 }
 
 
@@ -417,9 +433,9 @@ sub send_basic_header
     my $self = shift;
     return if $self->antique_client;
     $self->send_status_line(@_);
-    print $self "Date: ", time2str(time), $CRLF;
+    $self->print ("Date: ", time2str(time), $CRLF);
     my $product = $self->daemon->product_tokens;
-    print $self "Server: $product$CRLF" if $product;
+    $self->print ("Server: $product$CRLF") if $product;
 }
 
 
@@ -429,7 +445,7 @@ sub send_header
     while (@_) {
 	my($k, $v) = splice(@_, 0, 2);
 	$v = "" unless defined($v);
-	print $self "$k: $v$CRLF";
+	$self->print ("$k: $v$CRLF");
     }
 }
 
@@ -471,8 +487,8 @@ sub send_response
 	    $self->force_last_request;
             $res->header('connection','close'); 
 	}
-	print $self $res->headers_as_string($CRLF);
-	print $self $CRLF;  # separates headers and content
+	$self->print ($res->headers_as_string($CRLF));
+	$self->print ($CRLF);	# separates headers and content
     }
     if ($self->head_request) {
 	# no content
@@ -485,13 +501,13 @@ sub send_response
 		printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
 	    }
 	    else {
-		print $self $chunk;
+		$self->print ($chunk);
 	    }
 	}
-	print $self "0$CRLF$CRLF" if $chunked;  # no trailers either
+	$self->print ("0$CRLF$CRLF") if $chunked;  # no trailers either
     }
     elsif (length $content) {
-	print $self $content;
+	$self->print ($content);
     }
 }
 
@@ -505,13 +521,13 @@ sub send_redirect
     my $base = $self->daemon->url;
     $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
     $loc = $loc->abs($base);
-    print $self "Location: $loc$CRLF";
+    $self->print ("Location: $loc$CRLF");
     if ($content) {
 	my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
-	print $self "Content-Type: $ct$CRLF";
+	$self->print ("Content-Type: $ct$CRLF");
     }
-    print $self $CRLF;
-    print $self $content if $content && !$self->head_request;
+    $self->print ($CRLF);
+    $self->print ($content) if $content && !$self->head_request;
     $self->force_last_request;  # no use keeping the connection open
 }
 
@@ -530,11 +546,11 @@ $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;
+        $self->print ("Content-Type: text/html$CRLF");
+	$self->print ("Content-Length: " . length($mess) . $CRLF);
+        $self->print ($CRLF);
     }
-    print $self $mess unless $self->head_request;
+    $self->print ($mess) unless $self->head_request;
     $status;
 }
 
@@ -555,11 +571,11 @@ sub send_file_response
 	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->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) unless $self->head_request;
 	return RC_OK;
@@ -595,7 +611,7 @@ sub send_file
     while ($n = sysread($file, $buf, 8*1024)) {
 	last if !$n;
 	$cnt += $n;
-	print $self $buf;
+	$self->print ($buf);
     }
     close($file) if $opened;
     $cnt;

-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.9 (GNU/Linux)

iEYEARECAAYFAkySKpsACgkQ+MvqjYjLOAy2XgCeLhEZZALI9wRg9i84VMkezufd
leYAoIg81ObngAzNq++1PiP9Q3HsIBa6
=j1/J
-----END PGP SIGNATURE-----