#!/usr/bin/perl
#
# quick and dirty signle threaded CGI executive
# can also be used to capture requests

use strict;
use warnings;
use IO::Socket::INET;
use IO::String;

my $port = shift(@ARGV) || 9000;
my $listen = IO::Socket::INET->new(
    Listen    => 5,
    LocalAddr => 'localhost',
    LocalPort => $port,
    Proto     => 'tcp',
    ReuseAddr => 1
);

unless ($listen) {
  die "unable to listen on port $port: $!\n"
};

while (1) {
  print STDERR "waiting for connection on port $port\n";
  my $s = $listen->accept();

  open(STDOUT, ">&=".fileno($s));
  open(STDIN, "<&=".fileno($s));

  my ($req, $content);
  delete $ENV{CONTENT_LENGTH};
  { local ($/) = "\r\n";
    while (<STDIN>) {
      $req .= $_;
      chomp;
      # print STDERR "got: $_\n";
      last unless /\S/;
      if (/^GET\s*(\S+)/) {
        $ENV{REQUEST_METHOD} = 'GET';
        (my $qs = $1) =~ m/\?(.*)/;
        $ENV{'QUERY_STRING'} = $1;
      } elsif (/^POST/) {
        $ENV{REQUEST_METHOD} = 'POST';
        $ENV{'QUERY_STRING'} = '';
      } elsif (/^Content-Type:\s*(.*)/) {
        $ENV{CONTENT_TYPE} = $1;
      } elsif (/^Content-Length:\s*(.*)/) {
        $ENV{CONTENT_LENGTH} = $1;
      }
    }
  }
  if (my $size = $ENV{CONTENT_LENGTH}) {
    $content = '';
    while (length($content) < $size) {
        my $nr = read(STDIN, $content, $size-length($content),
                      length($content));
        die "read error" unless $nr;
    }
  }

  # can save $req, $content here:
  # open(F, ">request"); print F $req, $content; close(F);

  close(STDIN); # n.b.: does not close socket
  tie *STDIN, 'IO::String', $content;

  undef @CGI::QUERY_PARAM;
  call_cgi();

  untie *STDIN;
  close(STDOUT);
  close($s);
}

sub call_cgi
{
    print "HTTP/1.0 200\r\n";

    # your CGI code goes here, example code follows

    use CGI;
    my $q = new CGI();

    print $q->header(-type => 'text/plain');
    print "Color = ", $q->param('color'), "\n";
    my $file = $q->param('myfile');
    print "myfile = ", $file, "\n";

    print "myfile contents:\n";
    while (<$file>) { print; }
    print "end of file\n";
}