#!/usr/bin/perl -w

use strict;

use Cwd qw( cwd );

use File::Spec;
$ENV{DOCUMENT_ROOT} = cwd();
chdir $ENV{DOCUMENT_ROOT};

use Data::Dumper;
use HTTP::Daemon;
use HTTP::Status;
use CGI::Simple();
use CGI();

my $port    = shift || 80;
my $docroot = shift || $ENV{DOCUMENT_ROOT};

my $d = HTTP::Daemon->new(
    Reuse     => 1,
    LocalPort => $port,
) or die "No daemon: $!\n";

warn "Ready to go!\n";
while (my $conn = $d->accept())
{
    handle_uri( $conn, $conn->get_request( 1 ));
}

sub handle_uri
{
    my ($conn, $req) = @_;
    my $uri  = $req->uri();
    
    if ($uri =~ /images/)
    {
        serve_image( $conn, $req, $uri );
    }
    else
    {
        serve_everything( $conn, $req, $uri );
    }
}

sub serve_everything
{
    my ($conn, $req) = @_;
    my $uri = $req->uri;

    $ENV{REQUEST_METHOD} = $req->method;
    $ENV{CONTENT_TYPE}   = join('; ', $req->content_type ) || '';
    $ENV{CONTENT_LENGTH} = $req->content_length || '';
    $ENV{HTTP_USER_AGENT} = join('; ', $req->user_agent ) || '';
    $ENV{SCRIPT_NAME}    = $uri->path  || 1;
    $ENV{QUERY_STRING}   = $uri->query || '';
    $ENV{HTTP_HOST} = $req->header('host');
    $ENV{REMOTE_ADDR} = $conn->peerhost();
    $ENV{REMOTE_PORT} = $conn->peerport();

    foreach my $c (qw( cookie cookies ))
    {
        $ENV{uc $c} = join(';', $req->header( $c ) ) || '';
    }

    my $cgi;
    {
#        warn '$ENV{CONTENT_LENGTH} = ',$ENV{CONTENT_LENGTH},$/;
#        local $_;
#        warn "read ", sysread($conn, $_, $ENV{CONTENT_LENGTH}, 0);
#        warn $_,$/,$/;
        local *main::STDIN = $conn;
        $cgi = CGI::Simple->new();
#        $cgi = CGI->new(); # CGI works, CGI::Simple hangs :(
    }

    $conn->send_response(
        HTTP::Response->new(
            200, 'OK',
            HTTP::Headers->new(
            Set_Cookie => $cgi->cookie(
                        -name =>'sessionID',
                        -value =>'xyzzy',
                        -expires =>'+1y',
                        -path =>'',
                        -domain => $ENV{HTTP_HOST},
                        -secure => 0
                    ),
            Content_Type => "text/html"),
            "<font size=2><pre>".
                CGI::Simple->escapeHTML(
                    scalar Dumper(
                        $conn, $req, \%ENV, $cgi
                    )
                ).
qq|
</font></pre>
<hr>
<FORM
  METHOD="GET"
  ACTION="$ENV{SCRIPT_NAME}"
  ENCTYPE="application/x-www-form-urlencoded">
    <input type="text" name"f">
    <input type="reset" name=".reset" />
    <input type="submit" name=".submit" />
</form>
<FORM
  METHOD="POST"
  ACTION="$ENV{SCRIPT_NAME}"
  ENCTYPE="application/x-www-form-urlencoded">
    <input type="text" name"f">
    <input type="reset" name=".reset" />
    <input type="submit" name=".submit" />
</form>
<FORM
  METHOD="POST"
  ACTION="$ENV{SCRIPT_NAME}"
  ENCTYPE="multipart/form-data">
    <INPUT TYPE="file" NAME="upload_file1" SIZE="42">
    <INPUT TYPE="file" NAME="upload_file2" SIZE="42">
    <input type="reset" name=".reset" />
    <input type="submit">
</FORM>
|
        )
    );

    $conn->print( 'nope', $@ ) if $@;
}

sub serve_image
{
    my ($conn, $req, $uri) = @_;
    my $file = File::Spec->catfile( $docroot, $uri );
    $conn->send_status_line( (-e $file ? 200 : 404 ) );
    $conn->send_file_response( $file );
}
[download]

The problem per se is that there is no eof reaching CGI::Simple. As a result it blocks (hangs) on the read here:

sub _read_data {
   read ( STDIN, my $buffer, 16 );  # nb changed buf size for testing
 return $buffer;
}
[download]

In essence the difference between the way CGI.pm reads data and what I did in this module is that CGI stops when it gets what it expects, thus it is not eof dependent.

It is actually quite interesting what happens. If you increase the buffer size on the read so it can slurp the data in one pass it works fine. It is only if you read bytewise that read (or sysread) fails to recognise the end of the data stream.

cheers

tachyon

So are you going to change the way that is handled in the next release? I suggest you do (you know, keep alive and whatnot).

MJD says "you can't just make shit up and expect the computer to know what you mean, retardo!"

I run a Win32 PPM repository for perl 5.6.x and 5.8.x -- I take requests (README).

** The third rule of perl club is a statement of fact: pod is sexy.