in reply to Windows Threaded Proxy Server

The main problem appears to be a lack of error handling in certain areas. For example: 

sub connectToHost {
...
    connect($Sock, $remote_port) || return (undef,"Socket Connect Erro
+r: $!");
...
}

...
sub processRequest {
...
    my( $UrlSock, $err ) = connectToHost( $Request{ host }, 80 );
...
    foreach my $line (@request){
        print $UrlSock $line;
    }

[download]

In connectToHost(), you return undef if the connect call fails, but in processRequest(), you never check $UrlSock has a value. If the connect fails, the print will result in 

Can't use an undefined value as a symbol reference at ...

[download]

There are also numerous places where you are using the results from regex captures without having checked that the regex matched:

Here you are assuming the 'http://' protocol: 

    $hash->{url} = ($firstline =~ m|(http://\S+)|)[0];
    if($hash->{url}=~/\?(.+)/s){
        $hash->{getdata}=$1;
        }
...
    $hash->{url}=~s/\?.*//s;

[download]

what about https://, news://, etc?

Similarly here. If neither of your regex match then $method is undef in the last if. 

    if($firstline =~ m!(GET|POST|HEAD) http://([^/:]+):?(\d*)!){
        $method=$1;
        $host=$2;
        $port=$3
        }
    elsif($firstline=~m!(CONNECT) ([^/:]+):?(\d*)!){
        $method=$1;
        $host=$2;
        $port=$3
        }
    $hash->{method}=$method;
...
    if ($method=~/^POST$/is && $len) {

[download]

Also, I think that your test for content type is woefully inadaquate: 

    #Get Reply Header
    my %Reply = ();
    my @reply = &readSocket( \%Reply, $UrlSock );
    if(
    defined $Reply{ 'content-type' }
        and
        $Reply{ 'content-type' } =~ m[^(image|application)]is
    ) {
        binmode $UrlSock;
        binmode $Client;
    }

[download]

As well as requiring the additional check to ensure that the content-type header was returned, your test for when to set binmode is very minimal. I also wonder if you couldn't get away with setting binmode for all connections? That would certainly simplify the processing but you will need to consult someone or some document with greater knowledge of the HTTP: protocol.

I noticed that as a result of these kind of errors, your worker threads slowly failed one by one until there were no threads left to service requests. Of course, when a thread dies, the other trheads carry on, but the response time slowly increases and eventually, then only thread left running is your status monitoring thread, which continues to indicate that the other threads are in whatever state they were in just before dieing. The addition of a die handler shoudl improve that: 

sub worker {
    my $tid = threads->tid();
    local $SIG{__DIE__} = sub{ $ThreadStatus{$tid} = 'died'; };
...

[download]

Whilst real signal don't play nice with threads, the __DIE__ and __WARN__ pseudo-signals work fine.

Having hacked around (Note: I haven't attempted to resolve them correctly!) some of these problems, I arrived at this code (sorry for having reformatted it so much, but please, whitespace is cheap:), then the proxy runs clean with zero memory growth, no handle consumption and reliably when left refreshing a fairly complex page that only uses the http:// protocol and contains a few dozen gifs and jpgs. I left it running for just over an hour refreshing the page every minute. But I disabled the Browsers caching first!!

That final point is (I think) critical. If I re-enable the browser caching, the proxy quickly becomes unresponsive.

Speculation warning! I think the reason for this is that when the browser is caching, it will issue requests for things but only read the reply upto the point where it gets a header that allows it to decide whether it needs to read the rest of that item or not. If it decides that the item hasn't been modified since it cached it, it just stops reading--but your proxy continues to try and process the rest of the data. The thread processing that request fails to detect that the browser has stopped reading data and hangs waiting for it to do so.

Slowly, this results in all your worker threads getting "stuck".

One suggestion. Whenever you are using threads, it makes a huge amount of sense to write a non-threaded version first. In this case, write the body of your protocol handling as a seperate module and call it from a standalone app that processes a single request at a time. Test that using hand-coded urls that fetch single text documents and then single gifs/jpegs/wav files etc. from http/https/ftp sources etc. It's a lot easier to debug the threading when your know that the protocol handling is correct first, and a lot easier to see when the protocol handling is wrong if only one request is being processed.

You are also more likely to get help from people regarding the protocol handling if they don't have to contend with the idea that the problems may be to do with the threading.

Here's my version of the code. As I said above, I haven't attempted to produce "correct" answers, just hacked my way passed them to get to the more important issues.

Good luck, and I would be interested in staying appraised of your progress. 

#!/usr/bin/perl
use strict;
use threads qw[ yield ];
use threads::shared;
use Thread::Queue;
use Thread::Queue::Any;
use Socket;

$|=1;

my $worker_cnt = 6;    #Number of worker threads to start
my $hostname = `hostname`;
$hostname = strip($hostname);
my $hostip = (gethostbyname($hostname))[4];
my %SocketInfo = (
    hostname    => $hostname,
    hostip        => $hostip,
);

print "creating thread queues ...";
my $Qwork       = new Thread::Queue::Any;
my $Qprint    = new Thread::Queue::Any;
my %ThreadStatus : shared = ();
my %ClientAddr : shared = ();
print "Done\n";

my @threads = ();
print "starting 1 writer thread ... \n";
my $cthread = threads->new(\&writer);
push(@threads,$cthread);
print "starting $worker_cnt worker threads ... ";

for(my $x = 0;$x<$worker_cnt;$x++){
    $cthread = threads->new(\&worker);
    push(@threads,$cthread);
}
print "Done\n";
my $threadcnt = @threads;

my $port = 8080;
my $address = '';
my $Server;
my ($name, $aliases, $protocol) = getprotobyname('tcp');
if ($port !~ /^\d+$/) {($name, $aliases, $port) = getservbyport($port,
+ 'tcp');}
my $proto = getprotobyname('tcp');
socket($Server,PF_INET,SOCK_STREAM,$proto) || die "Socket Connection E
+rror : $!";
setsockopt($Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))     || die
+ "SettingSocket Option Error: $!";
bind($Server, sockaddr_in($port, INADDR_ANY)) || die "Cannot bind Sock
+et : $!";
listen($Server,SOMAXCONN) || die "Error listening on Socket: $!";
binmode $Server;
select($Server);$| = 1;
select(STDOUT);$|= 1;

###  Listener on Socket for Client Requests
# Use fileno to pass Globs between threads
#     http://www.perlmonks.org/index.pl?node_id=395373
print "Listening on port $port\n";
my $Client;
while (my $addr = accept($Client, $Server)){
    $Qwork->enqueue(fileno $Client,$addr,"");
    #sleep for 1 millisecond to avoid pegging the CPU
    select(undef,undef,undef,.01);
}

###  send a Die message to each thread by putting a die message in the
+ queue for each thread to get.

$Qwork->enqueue(["",'DIE_NOW']) for 1 .. @threads;

###  Join threads - cleanup and exit
#$_->join for @threads;  - this should work but causes a crash.. Let w
+indows clean up the threads.
use POSIX qw[_exit];
_exit( 0 );
#################################################################

sub writer {
    #Grab items from the Qprint queue and print them to STDOUT
    my $tid = threads->tid();
    $ThreadStatus{$tid} = 'idle';
    while(1){
        select(undef,undef,undef,.01) until $Qprint->pending();
        $ThreadStatus{$tid} = 'working';
        my ($thrid,$msg) = $Qprint->dequeue;
        last if length($msg) && $msg=~/^DIE NOW$/is;
        print "[$thrid] $msg\n";
        #Show the state of each thread
        foreach my $tid (sort(keys(%ThreadStatus))){
            print STDOUT "\t$tid is $ThreadStatus{$tid}\n";
        }
        $ThreadStatus{$tid} = 'idle';
        #sleep for 1 millisecond to avoid pegging the CPU
        select(undef,undef,undef,.01);
    }
    return 1;
}

sub worker {
    my $tid = threads->tid();
    local $SIG{__DIE__} = sub{ $ThreadStatus{$tid} = 'died'; };
    $ThreadStatus{$tid} = 'idle';
    while(1){
        select undef, undef, undef, .01  until $Qwork->pending();
        $ThreadStatus{$tid} = 'working';
        my ($fno,$addr,$action) = $Qwork->dequeue;
        last if length($action) && $action ne 'DIE NOW';
        open( $Client, "+<&=$fno" ) || last;
        #Process Request;
        processRequest( $Client, $addr, $tid );
        close($Client);
        $ThreadStatus{$tid} = 'idle';
    }
    return 1;
}

sub processRequest {
    my $Client = shift || return;
    my $addr = shift || return;
    my $tid = shift;

    $Qprint->enqueue( $tid, "Processing" );
    $ThreadStatus{ $tid } = 'processing';

    my $socket_format = 'S n a4 x8';
    my @tmp = unpack( $socket_format, $addr );
    my $port = $tmp[ 1 ];
    my $inetaddr = $tmp[2];
    my @inetaddr = unpack('C4',$inetaddr);
    my $client_ip = join(".", @inetaddr);
    my $client_host = gethostbyaddr( $inetaddr, AF_INET );
    my %Request = ();
    my @request = readSocket( \%Request, $Client );
    my( $UrlSock, $err ) = connectToHost( $Request{ host }, 80 );

    #Send Request to the internet
    $request[0] =~ s[http://[^/]+][];
    $request[0] =~ s[HTTP/1.1][HTTP/1.0];
    foreach my $line (@request){
        print $UrlSock $line;
    }
    if( exists $Request{ postdata } and length( $Request{ postdata } )
+ ) {
        print $UrlSock $Request{ postdata };
    }

    #Get Reply Header
    my %Reply = ();
    my @reply = &readSocket( \%Reply, $UrlSock );
    if(
        defined $Reply{ 'content-type' }
        and
        $Reply{ 'content-type' } =~ m[^(image|application)]is
    ) {
        binmode $UrlSock;
        binmode $Client;
    }

    #Print the Reply Header to the browser client
    print $Client @reply;
    $Qprint->enqueue(
        $tid,
        sprintf "Listening for %s from %s",
            $Reply{'content-type'}||'Unknown content type',
            $Request{host} || 'Unknown host'
    );
    $ThreadStatus{ $tid } = 'waiting for reply [0]';
    my $clen = 0;
    my $linecnt = 0;
    while( <$UrlSock> ) {
        my $line = $_;
        $linecnt++;
        $ThreadStatus{$tid} = "reading reply line $linecnt";
        print $Client $line;
        if( $Reply{'content-length'} && $Reply{'content-length'} > 0 )
+{
            $clen += length($line);
            last if $clen >= $Reply{'content-length'};
        }
        last if $line=~/\<\/html\>/is;
        last if $line=~/^0$/s;
        if($line=~/\<\/body\>$/is){
            print $Client qq|</html>|;
            last;
        }
    }
}

sub readSocket{
    my $hash = shift || return "No Hash Reference";
    my $Socket = shift || return "No Socket";
    binmode $Socket;
    my @lines = ();
    %{$hash} = ();
    #Read in First line and process it
    my $firstline = <$Socket>;
    $hash->{ request } = strip( $firstline );
    push( @lines, $firstline );
    if(
        $hash->{url} = ( $firstline =~ m[(http://\S+)] )[ 0 ]
        and
        $hash->{url} =~ m[\?(.+)]s
    ){
        $hash->{getdata} = $1;
    }
    #Method,host,port
    my( $method, $host, $port );
    #POST http://www.basgetti.com/cgi-bin/wasql.pl HTTP/1.1
    #CONNECT www.netteller.com:443 HTTP/1.1
    if( $firstline =~ m[(GET|POST|HEAD) http://([^/:]+):?(\d*)] ) {
        $method = $1;
        $host = $2;
        $port = $3
    }
    elsif( $firstline =~ m[(CONNECT) ([^/:]+):?(\d*)] ) {
        $method = $1;
        $host = $2;
        $port = $3
    }
    $hash->{method} = $method;
    $hash->{host} = $host;
    $hash->{port} = $port;
    #Read in rest of Header
    while( <$Socket> ) {
        next if m[(Proxy-Connection:|Keep-Alive:|Accept-Encoding:)];
        if( m[^([a-z\-]+)\:(.+)]is ) {
            my $attr = lc strip( $1 );
            my $val = lc strip( $2 );
            $hash->{$attr} = $val;
        }
        push @lines,$_;
        last if m[^[\s\x00]*$];
    }
    my $len = $hash->{'content-length'} ? $hash->{'content-length'} : 
+0;
    if( defined $method and $method =~ m[^POST$]is && $len ) {
        my $data = '';
        my $dlen = 0;
        my $bytes = $len > 2048 ? 2048 : $hash->{'content-length'};
        while( $dlen < $len ){
            my $cdata;
            my $n = read( $Socket, $cdata, $bytes );
            $data .= $cdata;
            $dlen = length($data);
            last if $n==0;
            last if !defined $n;
            select(undef,undef,undef,.01);
        }
        $hash->{'postdata'} = $data;
    }
    $hash->{url} =~ s[\?.*][]s if exists $hash->{url} and defined $has
+h->{url};
    return @lines;
}

sub connectToHost {
    # Create a socket that connects to a certain host
    # connectToHost($MainSock, $remote_hostname, $port)
    my( $remote_hostname, $port ) = @_;
    my $Sock;
    my( $socket_format, $proto, $packed_port, $cur );
    my( $remote_addr, @remote_ip, $remote_ip );
    my( $local_port, $remote_port );
    if( $port !~ m[^\d+$] ) {
        $port = ( getservbyname( $port, "tcp" ) )[ 2 ];
        $port = 80 unless $port;
    }
    $proto = ( getprotobyname( 'tcp' ) )[ 2 ];
    $remote_addr = ( gethostbyname( $remote_hostname ) )[ 4 ];
    if( !$remote_addr ) {
        return ( undef, "Unknown host: $remote_hostname" );
    }
    @remote_ip = unpack("C4", $remote_addr);
    $remote_ip = join(".", @remote_ip);
    $socket_format = 'S n a4 x8';
    $local_port = pack($socket_format, &AF_INET, 0, $SocketInfo{hostip
+});
    $remote_port = pack($socket_format, &AF_INET, $port, $remote_addr)
+;
    socket($Sock, &AF_INET, &SOCK_STREAM, $proto) || return (undef,"So
+cket Error: $!");
    bind($Sock, $local_port) || return (undef,"Socket Bind Error: $!")
+;
    connect($Sock, $remote_port) || return (undef,"Socket Connect Erro
+r: $!");
    $cur = select($Sock);
    $| = 1; # Disable buffering on socket.
    select($cur);
    return $Sock;
}

sub strip{
    #usage: $str=strip($str);
    #info: strips off beginning and endings returns, newlines, tabs, a
+nd spaces
    my $str = shift;
    if( length($str) == 0 ){return;}
    $str=~s/^[\r\n\s\t]+//s;
    $str=~s/[\r\n\s\t]+$//s;
    return $str;
}

[download]
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
Lingua non convalesco, consenesco et abolesco. -- Rule 1 has a caveat! -- Who broke the cabal?
"Science is about questioning the status quo. Questioning authority".
The "good enough" maybe good enough for the now, and perfection maybe unobtainable, but that should not preclude us from striving for perfection, when time, circumstance or desire allow.

Replies are listed 'Best First'.
Re^2: Windows Threaded Proxy Server
by slloyd (Hermit) on May 28, 2005 at 04:52 UTC
    Thank you for your post. It has helped me quite a bit. I have made some more modifications, including a window to watch the threads. If a thread dies, a new one gets created in it's place. It works pretty well now. Thanks again. Code is Below: 
    #!/usr/bin/perl
use strict;
use threads qw[ yield ];
use threads::shared;
use Thread::Queue;
use Thread::Queue::Any;
use Socket;
use Win32::GUI;
use Win32::GUI::AxWindow;
use POSIX qw[_exit];
$|=1;

our $MainWindow = new Win32::GUI::Window(
    -name   => "MainWindow",
    -text   => "Thread Watcher",
    -width  => 500,
    -height    => 500,
    -minsize  => [500, 500],
    -maxsize  => [500, 500],
    -pos     => [300, 100 ],
    );
$MainWindow->AddLabel (
    -name => "Thread\_Header",
    -text => pack("A5 A*"," Thr ","Information"),
    -pos  => [10, 0],
    -size => [480, 20]
    );

my $worker_cnt = 8;    #Number of worker threads to start
my $hostname = `hostname`;
$hostname = strip($hostname);
my $hostip = (gethostbyname($hostname))[4];
my %SocketInfo = (
    hostname    => $hostname,
    hostip        => $hostip,
    );

print "creating thread queues ...";
my $Qwork       = new Thread::Queue::Any;
my $Qprint    = new Thread::Queue::Any;
my %ThreadStatus : shared = ();
my %ThreadLabel : shared = ();
my %ThreadClient : shared = ();
my %ThreadAddr : shared = ();
print "Done\n";

print "starting 1 writer thread ... \n";
my $cthread = threads->new(\&writer);
my $thrid=$cthread->tid();
$MainWindow->AddLabel (
    -name => "Label1",
    -text => pack("A5 A20 A*",$thrid,"Sock Server",""),
    -pos  => [10, 20],
    -size => [480, 20]
    );
$ThreadLabel{$thrid}='Label1';
print "starting 1 socketServer thread ... \n";
$cthread = threads->new(\&socketServer);
$thrid=$cthread->tid();
$MainWindow->AddLabel (
    -name => "Label2",
    -text => pack("A5 A20 A*",$thrid,"Sock Server",""),
    -pos  => [10, 40],
    -size => [480, 20]
    );
$ThreadLabel{$thrid}='Label2';
print "starting $worker_cnt worker threads ... ";
for(my $x = 0;$x<$worker_cnt;$x++){
    $cthread = threads->new(\&worker);
    #Add a label to the gui for each thread
    my $y=int(60+(30*$x));
    my $thrid=$cthread->tid();
    my $label="Label" . int($x+3);
    $MainWindow->AddLabel (
        -name => $label,
        -text => pack("A5 A20 A*",$thrid,"Started",""),
        -pos  => [10, $y],
        -size => [480, 30]
        );
    $ThreadLabel{$thrid}=$label;
    }
print "Done\n";
$MainWindow->Show();
$MainWindow->AddTimer('Report', 250);
Win32::GUI::Dialog();

###  Listener on Socket for Client Requests
# Use fileno to pass Globs between threads
#     http://www.perlmonks.org/index.pl?node_id=395373


###  send a Die message to each thread by putting a die message in the
+ queue for each thread to get.
my @threads=keys(%ThreadLabel);
my $threadcnt=@threads;
$Qwork->enqueue(["","",1]) for 1 .. $threadcnt;

#Wait for Keyboard input before exiting the windows Dialog
print STDOUT "Press any key to exit\n";
my $inp=<STDIN>;
###  Join threads - cleanup and exit
#$_->join for @threads;  - this should work but causes a crash.. Let w
+indows clean up the threads.
_exit( 0 );
#################################################################
sub Report_Timer{
    foreach my $tid (sort(keys(%ThreadStatus))){
        my $label=$ThreadLabel{$tid};
        my $status=$ThreadStatus{$tid};
        if($status=~/died/is){
                delete($ThreadLabel{$tid});
                delete($ThreadStatus{$tid});
                $Qprint->enqueue($tid,"Dead - Creating a new thread");
                my $cthread = threads->new(\&worker);
                my $thrid=$cthread->tid();
                $Qprint->enqueue($thrid,"New thread created - $thrid")
+;
                $ThreadLabel{$thrid}=$label;
                $ThreadStatus{$thrid}='new';
                $status='new';
                }
        if($MainWindow->{$label}){
            #print STDOUT "Updating $label\n";
            $MainWindow->{$label}->Text(pack("A5 A*",$tid,$status));

            }
        #else{print STDOUT "No Label $label\n";}
        }
    }
sub MainWindow_Terminate {
    return -1;
    }
############
sub socketServer{
    my $tid = threads->tid();
    $ThreadStatus{$tid} = "Sock Server - Starting";
    my $port = 8080;
    my $address = '';
    my $Server;
    my ($name, $aliases, $protocol) = getprotobyname('tcp');
    if ($port !~ /^\d+$/) {($name, $aliases, $port) = getservbyport($p
+ort, 'tcp');}
    my $proto = getprotobyname('tcp');
    socket($Server,PF_INET,SOCK_STREAM,$proto) || die "Socket Connecti
+on Error : $!";
    setsockopt($Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))     ||
+ die "SettingSocket Option Error: $!";
    bind($Server, sockaddr_in($port, INADDR_ANY)) || die "Cannot bind 
+Socket : $!";
    listen($Server,SOMAXCONN) || die "Error listening on Socket: $!";
    binmode $Server;
    select($Server);$| = 1;
    select(STDOUT);$|= 1;
    $ThreadStatus{$tid} = "Sock Server - Listening";
    my $Client;
    my $cnt=0;
    while (my $addr = accept($Client, $Server)){
        $cnt++;
        $ThreadStatus{$tid} = "Sock Server - Enqueue Job # $cnt";
        $Qwork->enqueue(fileno $Client,$addr,"");
        #sleep for 1 millisecond to avoid pegging the CPU
        select(undef,undef,undef,.01);
        $ThreadStatus{$tid} = "Sock Server - Listening";
        }
    }
#################################################################
sub writer {
    #Grab items from the Qprint queue and print them to STDOUT
    my $tid = threads->tid();
    $ThreadStatus{$tid} = 'Writer - idle';
    while(1){
        select(undef,undef,undef,.01) until $Qprint->pending();
        $ThreadStatus{$tid} = 'Writer - Dequeue';
        my ($thrid,$msg) = $Qprint->dequeue;
        if(length($msg) && $msg=~/^DIE NOW$/is){
            $ThreadStatus{$tid} = 'Writer - Died';
            last;
            }
        print "[$thrid] $msg\n";
        #Show the state of each thread
        #foreach my $tid (sort(keys(%ThreadStatus))){
         #   print STDOUT "\t$tid is $ThreadStatus{$tid}\n";
        #}
        $ThreadStatus{$tid} = 'Writer - idle';
        #sleep for 1 millisecond to avoid pegging the CPU
        select(undef,undef,undef,.01);
        }
    return 1;
    }

sub worker {
    my $tid = threads->tid();
    local $SIG{__DIE__} = sub{
        $ThreadStatus{$tid} = 'died';
       # $Qprint->enqueue($tid,"Thread $tid Died - ReQueueing the Job 
+$ThreadClient{$tid}");
       # $Qwork->enqueue($ThreadClient{$tid},$ThreadAddr{$tid},"");
        return 1;
        };
    $ThreadStatus{$tid} = 'idle';
    while(1){
        select undef, undef, undef, .01  until $Qwork->pending();
        $ThreadStatus{$tid} = 'DQ';
        my ($fno,$addr,$action) = $Qwork->dequeue;
        $ThreadClient{$tid}=$fno;
        $ThreadAddr{$tid}=$addr;
        last if length($action) && int($action)==1;
        my $Client;
        $ThreadStatus{$tid} = 'Open Client';
        if(open( $Client, "+<&=$fno" )){
            #Process Request;
            $ThreadStatus{$tid} = 'Send Request for Processing';
            processRequest( $Client, $addr, $tid );
            $ThreadStatus{$tid} = 'Done Processing - Closing Client';
            if($Client){close($Client);}
            }
        else{
            $ThreadStatus{$tid} = 'Open Client Failed';
            }
        $ThreadStatus{$tid} = 'idle';
        }
    $ThreadStatus{$tid} = 'Done - Returning';
    return 1;
    }

sub processRequest {
    my $Client = shift || return;
    my $addr = shift || return;
    my $tid = shift;
    #$Qprint->enqueue( $tid, "Processing" );
    $ThreadStatus{$tid} = 'processing';
    my $socket_format = 'S n a4 x8';
    my @tmp = unpack( $socket_format, $addr );
    my $port = $tmp[ 1 ];
    my $inetaddr = $tmp[2];
    my @inetaddr = unpack('C4',$inetaddr);
    my $client_ip = join(".", @inetaddr);
    my $client_host = gethostbyaddr( $inetaddr, AF_INET );
    $ThreadStatus{$tid} = "Reading Request from $client_host";
    my %Request = ();
    my @request = readSocket( \%Request, $Client );
    $ThreadStatus{$tid} = "Connect Internet Sock - $Request{url}";
    my( $UrlSock, $err ) = connectToHost( $Request{ host }, 80 );
    $ThreadStatus{$tid} = 'Write Request to Internet Sock';
    #Send Request to the internet
    $request[0] =~ s[http://[^/]+][];
    $request[0] =~ s[HTTP/1.1][HTTP/1.0];
    foreach my $line (@request){
        print $UrlSock $line;
        }
    if( exists $Request{ postdata } and length( $Request{ postdata } )
+ ) {
        print $UrlSock $Request{ postdata };
        }

    #Get Reply Header
    $ThreadStatus{$tid} = 'Read Internet Sock Reply';
    my %Reply = ();
    my @reply = &readSocket( \%Reply, $UrlSock );
    $ThreadStatus{$tid} = 'Read Internet Sock Reply - OK';
    binmode $UrlSock;
    binmode $Client;
    if($Request{url}=~/\.2o7\.net/is){
        close($UrlSock);
        return;
        }
    $ThreadStatus{$tid} = 'Write Reply Header';
    #Print the Reply Header to the browser client
    print $Client @reply;
    $ThreadStatus{ $tid } = 'Read Internet Sock Body';
    my $clen = 0;
    my $readcnt = 0;
    while( 1 ) {
        my $line;
        $ThreadStatus{$tid} = "Reading Next Line";
        my $n = read( $UrlSock, $line, 8192 );
        $clen += length($line);
           last if $n==0;
           $ThreadStatus{$tid} = "Reading Next Line Done - [$readcnt] 
+[$clen] [$Reply{'content-length'}]";
        $readcnt++;
        if($readcnt>500){
            $ThreadStatus{$tid} = "timed out Reading";
            $Qprint->enqueue($tid,"Timed out");
            last;
            }

        $ThreadStatus{$tid} = "Read Internet Sock Body - line $readcnt
+";
        print $Client $line;
        if( $Reply{'content-length'} && $Reply{'content-length'} > 0 )
+{

            if($clen >= $Reply{'content-length'}){
                $ThreadStatus{$tid} = "Content Length Reached";
                last;
                }
            }
        last if $line=~/\<\/html\>/is;
        last if $line=~/^0$/s;
        if($line=~/\<\/body\>$/is){
            print $Client qq|</html>|;
            last;
            }
         $ThreadStatus{$tid} = "Sleeping";
        select(undef,undef,undef,.01);
        }
    $ThreadStatus{$tid} = "Done Processing";
    return 1;
    }

sub readSocket{
    my $hash = shift || return "No Hash Reference";
    my $Socket = shift || return "No Socket";
    binmode $Socket;
    my @lines = ();
    %{$hash} = ();
    #Read in First line and process it
    my $firstline = <$Socket>;
    $hash->{ request } = strip( $firstline );
    push( @lines, $firstline );
    if(
        $hash->{url} = ( $firstline =~ m[(http://\S+)] )[ 0 ]
        and
        $hash->{url} =~ m[\?(.+)]s
    ){
        $hash->{getdata} = $1;
    }
    #Method,host,port
    my( $method, $host, $port );
    #POST http://www.basgetti.com/cgi-bin/wasql.pl HTTP/1.1
    #CONNECT www.netteller.com:443 HTTP/1.1
    if( $firstline =~ m[(GET|POST|HEAD) http://([^/:]+):?(\d*)] ) {
        $method = $1;
        $host = $2;
        $port = $3
    }
    elsif( $firstline =~ m[(CONNECT) ([^/:]+):?(\d*)] ) {
        $method = $1;
        $host = $2;
        $port = $3
    }
    $hash->{method} = $method;
    $hash->{host} = $host;
    $hash->{port} = $port;
    #Read in rest of Header
    while( <$Socket> ) {
        next if m[(Proxy-Connection:|Keep-Alive:|Accept-Encoding:)];
        if( m[^([a-z\-]+)\:(.+)]is ) {
            my $attr = lc strip( $1 );
            my $val = lc strip( $2 );
            $hash->{$attr} = $val;
        }
        push @lines,$_;
        last if m[^[\s\x00]*$];
    }
    my $len = $hash->{'content-length'} ? $hash->{'content-length'} : 
+0;
    if( defined $method and $method =~ m[^POST$]is && $len ) {
        my $data = '';
        my $dlen = 0;
        my $bytes = $len > 2048 ? 2048 : $hash->{'content-length'};
        while( $dlen < $len ){
            my $cdata;
            my $n = read( $Socket, $cdata, $bytes );
            $data .= $cdata;
            $dlen = length($data);
            last if $n==0;
            last if !defined $n;
            select(undef,undef,undef,.01);
        }
        $hash->{'postdata'} = $data;
    }
    $hash->{url} =~ s[\?.*][]s if exists $hash->{url} and defined $has
+h->{url};
    return @lines;
}

sub connectToHost {
    # Create a socket that connects to a certain host
    # connectToHost($MainSock, $remote_hostname, $port)
    my( $remote_hostname, $port ) = @_;
    my $Sock;
    my( $socket_format, $proto, $packed_port, $cur );
    my( $remote_addr, @remote_ip, $remote_ip );
    my( $local_port, $remote_port );
    if( $port !~ m[^\d+$] ) {
        $port = ( getservbyname( $port, "tcp" ) )[ 2 ];
        $port = 80 unless $port;
    }
    $proto = ( getprotobyname( 'tcp' ) )[ 2 ];
    $remote_addr = ( gethostbyname( $remote_hostname ) )[ 4 ];
    if( !$remote_addr ) {
        return ( undef, "Unknown host: $remote_hostname" );
    }
    @remote_ip = unpack("C4", $remote_addr);
    $remote_ip = join(".", @remote_ip);
    $socket_format = 'S n a4 x8';
    $local_port = pack($socket_format, &AF_INET, 0, $SocketInfo{hostip
+});
    $remote_port = pack($socket_format, &AF_INET, $port, $remote_addr)
+;
    socket($Sock, &AF_INET, &SOCK_STREAM, $proto) || return (undef,"So
+cket Error: $!");
    bind($Sock, $local_port) || return (undef,"Socket Bind Error: $!")
+;
    connect($Sock, $remote_port) || return (undef,"Socket Connect Erro
+r: $!");
    $cur = select($Sock);
    $| = 1; # Disable buffering on socket.
    select($cur);
    return $Sock;
}

sub strip{
    #usage: $str=strip($str);
    #info: strips off beginning and endings returns, newlines, tabs, a
+nd spaces
    my $str = shift;
    if( length($str) == 0 ){return;}
    $str=~s/^[\r\n\s\t]+//s;
    $str=~s/[\r\n\s\t]+$//s;
    return $str;
}

    [download]
[reply]
[d/l]

In Section Seekers of Perl Wisdom