sub update results from the CPAN

HTTP-ProxyTest
view release on metacpan or search on metacpan
				croak "Argument -$_: The user this script runs as ",
				  "does not have write access to '$file'";
			}
			require File::Basename;
			my $dir = ( File::Basename::fileparse($file) )[1];
			if ( -d $dir ) {
				last PATHCHECKS if -r $dir and -w _ and -x _;
				croak "Argument -$_: The user this script runs as ",
				  "does not have write access to '$dir'";
			}
			croak "Argument -$_: Can't find any directory '$dir'";
		}
	}

	for ('primary', 'secondary') {
		if ( exists $args{$_} ) {
			ref($args{$_}) eq 'ARRAY' or croak "Argument -$_ shall be an arrayref";
			my $err = grep /\D/ || $_ < 0 || $_ > 65535, @{ $args{$_} };
			$err == 0 or croak "Argument -$_: $err elements are not valid port numbers";
		} else {
			$args{$_} = $defaults{$_};
		}
	}
	$args{primary}->[0] or $args{secondary}->[0] or
	  croak 'There should be at least one port to test';
	unless ( $args{nmap} or $args{primary}->[0] ) {
		croak 'Argument -primary may not refer to an empty list when no Nmap scanning is done';
	}

	for ('timeout', 'log_maxbytes') {
		if ( $args{$_} ) {
			$args{$_} =~ /^\d+$/ or croak "Argument -$_ shall be a positive integer";
		} else {
			$args{$_} = $defaults{$_};
		}
	}

	for ('test_url', 'content_substr') {
		$args{$_} ||= $defaults{$_};
	}
	$useragent = LWP::UserAgent->new(
		timeout => $args{timeout},
		agent => "HTTP::ProxyTest/$VERSION",
		requests_redirectable => [],
	);
	my $res = $useragent->get( $args{test_url} );
	unless ( $res->is_success ) {
		# no fatal error, since a temporary glitch
		# might be the cause of the failure
		carp 'Argument -test_url: Response status ', $res->status_line;
		return undef;
	}
	unless ( index( $res->content, $args{content_substr} ) >= 0 ) {
		croak 'Argument -content_substr: The string ',
		  "'$args{content_substr}' not found in the source of $args{test_url}";
	}

	\%args
}

sub update_whitelist {
	my $whitelist = shift;
	return {} unless $whitelist;

	tie my %white, 'SDBM_File', $whitelist, O_CREAT|O_RDWR, 0666 or die $!;
	my @oldies = grep $white{$_} < $time - 604800, keys %white;
	delete @white{ @oldies };
	\%white
}

sub portselect {
	my ($ip, $args) = @_;
	return $args->{primary} unless $args->{nmap};

	my (%count, @open, @filtered);
	my $ports = join ',', map { $count{$_}++ ? () : $_ }
	  @{ $args->{primary} }, @{ $args->{secondary} };
	my $nmap_result = qx( $args->{nmap} -PN -p $ports $ip );
	croak 'Nmap scan failed' if !$nmap_result or $?;
	while ( $nmap_result =~ m,^(\d+)/tcp\s+(open|filtered)\b,gm ) {
		my ($port, $state) = ($1, $2);
		if ( $state eq 'open' ) {
			push @open, $port;
		} elsif ( grep $_ eq $port, @{ $args->{primary} } ) {
			push @filtered, $port;
		}
	}
	[ @open, @filtered ]
}

sub caught {
	my ($ip, $port, $args) = @_;
	my $host = gethostbyaddr( pack('C4', split /\./, $ip), 2 ) || "IP $ip";
	print "Status: 403 Forbidden\n",
	      "Content-type: text/html; charset=UTF-8\n\n";
	print "<html><head><title>403 Forbidden</title></head><body>\n",
	      "<h1>403 Forbidden</h1>\n<p>The host you are using (<tt>$host</tt>) ",
	      "appears to carry an open proxy on port $port.</p>\n",
	      "</body></html>\n";
	return unless $args->{log};

	open my $log, '+>>', $args->{log} or die $!;
	flock $log, LOCK_EX;
	print $log "Date:      ", scalar localtime $time, "\n",
	           "URL:       ", ( lc substr($ENV{REQUEST_URI}, 0, 4) eq 'http' ?
	             '' : "http://$ENV{HTTP_HOST}" ), "$ENV{REQUEST_URI}\n",
	           "IP:        $ip\n";
	print $log "Host name: $host\n" unless substr($host, 3) eq $ip;
	print $log "Port:      $port\n\n";

	my $oldfh = select $log; $|++; select $oldfh;
	return unless -s $log > $args->{log_maxbytes};

	seek $log, $args->{log_maxbytes} / 2, 0;
	my $latest = do { local $/; <$log> };
	$latest =~ s/.+?\n\n//s;
	seek $log, 0, 0;
	truncate $log, 0;
	print $log $latest;
}
( run in 0.817 second using v1.01-cache-2.11-cpan-e1769b4cff6 )