#!/home/merlyn/bin/perl
    #use strict;
    use LWP::UserAgent;
    use HTTP::Cookies;
    $ENV{PATH} = join ":", qw(/usr/ucb /bin /usr/bin);
    $|++;


    $log_file_path = "proxy.log";
    $log = 2;


    ## Copyright (c) 1996 by Randal L. Schwartz
    ## This program is free software; you can redistribute it
    ## and/or modify it under the same terms as Perl itself.

   ## Anonymous HTTP proxy (handles http:, gopher:, ftp:)
   ## requires LWP 5.04 or later

   my $HOST = "10.0.0.186";
   my $PORT = "8008";
   my $REFERER = "http://www.domain.com";

   sub prefix {
     my $now = localtime;

     join "", map { "[$now] [${$}] $_\n" } split /\n/, join "", @_;
   }

   $SIG{__WARN__} = sub { warn prefix @_ };
   $SIG{__DIE__} = sub { die prefix @_ };
   $SIG{CLD} = $SIG{CHLD} = sub { wait; };

   #my $AGENT;                      # global user agent (for efficiency)
   #BEGIN {
   #  use LWP::UserAgent;

   #  @MyAgent::ISA = qw(LWP::UserAgent); # set inheritance

   #  $AGENT = MyAgent->new;
   #  $AGENT->agent("anon/0.07");
   #  $AGENT->env_proxy;
   #}

   #my $cookie_jar = HTTP::Cookies->new;
   my $ua = LWP::UserAgent->new;

   #$ua->cookie_jar($cookie_jar);

   sub LWP::UserAgent::redirect_ok { 0 } # redirects should pass through

   {                               ### MAIN ###
     use HTTP::Daemon;

     my $master = new HTTP::Daemon
       LocalAddr => $HOST, LocalPort => $PORT;
     warn "set your proxy to <URL:", $master->url, ">";
     my $slave;
     &handle_connection($slave) while $slave = $master->accept;
     exit 0;
   }                               ### END MAIN ###

   sub handle_connection {
     &logging( 2, "Handling conection" );
     my $connection = shift;       # HTTP::Daemon::ClientConn
     my $pid = fork();
     if ($pid) {                   # spawn OK, and I'm the parent
       close $connection;
       return;
     }
     ## spawn failed, or I'm a good child
     &logging( 2, "I am the child procces" );
     my $request = $connection->get_request;
     &logging( 2, "Creating Request object from browser call" );
     if (defined($request)) {
       &logging( 2, "Fetching request" );
       my $response = &fetch_request($request);
       &logging( 2, "Sending response" );
       $connection->send_response($response);
       &logging( 2, "Response sended, closing connection" );
       close $connection;
     } else { warn "request not defined"; }
     exit 0 if defined $pid;       # exit if I'm a good child with a good parent
   }

   sub fetch_request {
     my $request = shift;          # HTTP::Request

     use HTTP::Response;

     my $url = $request->url;
     &logging( 2, "Validating URL" );
     if ($url->scheme !~ /^(http|gopher|ftp)$/) {
       my $res = HTTP::Response->new(403, "Forbidden");
       $res->content("bad scheme: @{[$url->scheme]}\n");
       $res;
     } elsif (not $url->rel->netloc) {
       my $res = HTTP::Response->new(403, "Forbidden");
       $res->content("relative URL not permitted\n");
       $res;
     } else {
       &fetch_validated_request($request);
     }
   }

   sub fetch_validated_request { # return HTTP::Response

     my $request = shift;  # HTTP::Request
     #print $request;
     ## uses global $AGENT

     ## warn "orig request: <<<", $request->headers_as_string, ">>>";
     &logging( 2, "Removing header information" );
     $request->remove_header(qw(User-Agent From Referer Cookie));
     ## warn "anon request: <<<", $request->headers_as_string, ">>>";
     &logging( 2, "Requesting page" );
     my $response = $ua->request($request);
     ## warn "orig response: <<<", $response->headers_as_string, ">>>";
     &logging( 2, "Removing cookie" );
     $response->remove_header(qw(Set-Cookie));
     ## warn "anon response: <<<", $response->headers_as_string, ">>>";
     $response;
  }


  # -------------------------------------------------------------------------
# logging
sub logging {
    my ( $time, $i );
    if ( @_[0] <= $log ) {
        if ( not open(LOG, ">>".$log_file_path) ) {
            &produce_error( 7 );
            die;
            }
        $time = localtime(time);
        if ( $file_lock ) { flock(LOG, 2); }
        print LOG "$time \t [${$}] \t @_[1] \r\n";
        close(LOG);
    }
}

##</code><code>##

refresh pressed
Wed May 29 12:07:31 2002 [720] 	 	 Handling conection 
Wed May 29 12:07:32 2002 [-1180] 	 I am the child procces
refresh pressed 
Wed May 29 12:08:40 2002 [720] 	 	 Handling conection 
Wed May 29 12:08:40 2002 [-1484] 	 I am the child procces
refresh pressed 
Wed May 29 12:08:50 2002 [720] 	 	 Handling conection 
Wed May 29 12:08:51 2002 [-1180] 	 Creating Request object from browser call 
Wed May 29 12:08:51 2002 [-1180] 	 Fetching request 
Wed May 29 12:08:51 2002 [-1180] 	 Validating URL 
Wed May 29 12:08:52 2002 [-1448] 	 I am the child procces
refresh pressed 
Wed May 29 12:09:26 2002 [720] 	 	 Handling conection 
Wed May 29 12:09:26 2002 [-1484] 	 Creating Request object from browser call 
Wed May 29 12:09:26 2002 [-1484] 	 Fetching request 
Wed May 29 12:09:26 2002 [-1484] 	 Validating URL
CRASH!!!!


---------------------------
Wed May 29 12:11:19 2002 	 [1276] 	 Handling conection 
Wed May 29 12:11:19 2002 	 [-1156] 	 I am the child procces
refresh pressed 
Wed May 29 12:11:37 2002 	 [1276] 	 Handling conection 
Wed May 29 12:11:38 2002 	 [-1528] 	 I am the child procces 
refresh pressed
Wed May 29 12:13:22 2002 	 [1276] 	 Handling conection 
Wed May 29 12:13:23 2002 	 [-1156] 	 Creating Request object from browser call 
Wed May 29 12:13:23 2002 	 [-1156] 	 Fetching request 
Wed May 29 12:13:23 2002 	 [-1156] 	 Validating URL 
Wed May 29 12:13:23 2002 	 [-1284] 	 I am the child procces
refresh pressed 
Wed May 29 12:13:40 2002 	 [1276] 	 Handling conection
CRASH!!!!