HTTP::ProxyCheck - a class to check the functionality of HTTP proxy servers.

    use HTTP::ProxyCheck;

    my $proxy       = 'proxy:8080';
    my $url         = 'http://search.cpan.org/';
    my $proxy_check = new HTTP::ProxyCheck(
        proxy       => $proxy,
        url         => $url,
        answer_size => 'header',
        print_error => 0,
    ) 
    or die $HTTP::ProxyCheck::error;

    print "Trying to connect to '$proxy' and retrieve '$url'\n";

    if ( $proxy_check->check() ) {
        print "'$proxy' returns:\n\n", $proxy_check->get_answer(), "\n\n";
    }
    else {
        print "Error: ", $proxy_check->get_error(), "\n";
    }

    my $proxy_check = new HTTP::ProxyCheck(
        proxy          => 'proxy:8080',
        url            => 'http://search.cpan.org',
        verbose_errors => 1,
        print_error    => 0,
        raise_error    => 1,
    );

    $proxy_check->set_answer_size( 'full' )
      or die $proxy_check->get_error();

    $proxy_check->check()
      or die $HTTP::ProxyCheck::error;

    my $proxy_check = new HTTP::ProxyCheck( proxy => 'proxy' )
      or die $HTTP::ProxyCheck::error;

    $method failed: $error_message

    $error_message

    HTTP::ProxyCheck version 1.2

    1.4 Thu May 25 10:47:42 CEST 2006
        - Added installation instructions to README

    1.3 Sun May  7 11:51:50 CEST 2006
        - Charles Longeau <chl attuxfamily dot org> made a small patch to 
          specify the user agent, instead of a fixed "HTTP::ProxyCheck/$VERSION"
          one.

    1.2 Sat May  8 09:38:02 CEST 2004
        - Fix to unset the error message of a previous IO::Socket::INET run
          Thanks to Ben Schnopp <ben at schnopp dot com>

    


    1.1 Tue Aug 12 19:45:00 CEST 2003
        - rewrote the module
        - added better error handling
        - updated POD

    1.0  Fri Feb 21 17:09:32 CET 2003
        - gone stable after detailed testing 
        - updated POD (synopsis)

    0.2  Fri Feb 21 11:57:43 CET 2003
        - added check(answer => $type)
        - renamed methods to gain more consistency
        - updated POD (synopsis, methods)

    0.1  Wed Feb  5 14:35:25 CET 2003
        - original version

    Thomas Weibel
    cpan@beeblebrox.net
    http://beeblebrox.net/

#===============================================================================
# HTTP::ProxyCheck Version 1.4, Thu May 25 10:47:42 CEST 2006
#===============================================================================
# Copyright (c) 2004 - 2006 Thomas Weibel. All rights reserved.
#
# This library is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# More information: See "pod2text ProxyCheck.pm"
#===============================================================================

package HTTP::ProxyCheck;

use strict;
use vars qw($answer $error $VERSION);
use warnings;

use Validate::Net;
use IO::Socket;

BEGIN {
    $VERSION = 1.4;
    $answer  = '';
    $error   = '';

    # Autoflush = True
    $| = 1;
}

sub new {
    my ( $class, %attr ) = @_;
    my $self = bless( {%attr}, $class );

    if ( $self->_init ) {
        return $self;
    }
    else {
        return $self->_throw( $self->{error} );
    }
}

sub check {
    my ( $self, %attr ) = @_;
    my ( $check_proxy, $check_url, $proxy, $url, $answer_size, $user_agent );

    #---------------------------------------------------------------------------
    # Parse attributes and set defaults
    #---------------------------------------------------------------------------

    # Set the proxy check attribute
    if ( defined $attr{check_proxy} ) {
        $check_proxy = $self->_get_bool( $attr{check_proxy} );
    }
    else {
        $check_proxy = $self->{check_proxy};
    }

    # Set the URL check attribute
    if ( defined $attr{check_url} ) {
        $check_url = $self->_get_bool( $attr{check_url} );
    }
    else {
        $check_url = $self->{check_url};
    }

    # Set the proxy address
    if ( defined $attr{proxy} ) {
        $proxy = $attr{proxy};
        unless ( $self->_check_proxy( $proxy, $check_proxy ) ) {
            return $self->_throw( $self->{error} );
        }
    }
    elsif ( defined $self->{proxy} ) {
        $proxy = $self->{proxy};
    }
    else {
        return $self->_throw(
q#No proxy defined. Set it as attribute of your 'HTTP::ProxyCheck' object or the 'check()' method. You can also set it with 'set_proxy()'.#
        );
    }

    # Set the URL
    if ( defined $attr{url} ) {
        $url = $attr{url};
        unless ( $self->_check_url( $url, $check_url ) ) {
            return $self->_throw( $self->{error} );
        }
    }
    elsif ( defined $self->{url} ) {
        $url = $self->{url};
    }
    else {
        return $self->_throw(
q#No url defined. Set it as attribute of your 'HTTP::ProxyCheck' object or the 'check()' method. You can also set it with 'set_url()'.#
        );
    }

    # Set the answer size
    if ( defined $attr{answer_size} ) {
        $answer_size = $attr{answer_size};
        unless ( $self->_check_answer_size($answer_size) ) {
            return $self->_throw( $self->{error} );
        }
    }
    elsif ( defined $self->{answer_size} ) {
        $answer_size = $self->{answer_size};
    }
    else {
        return $self->_throw(
q#No answer_size defined. Set it as attribute of your 'HTTP::ProxyCheck' object or the 'check()' method. You can also set it with 'set_answer_size()'.#
        );
    }

    # Set the user agent
    if ( defined $attr{user_agent} ) {
        $user_agent = $attr{user_agent};
    }
    elsif ( defined $self->{user_agent} ) {
        $user_agent = $self->{user_agent};
    }
    else {
        $user_agent = "HTTP::ProxyCheck/" . $VERSION;
    }

    #---------------------------------------------------------------------------
    # Proxy check
    #---------------------------------------------------------------------------

    my ( $i, @answer, $answer, @header, $request, $line, $EOL );

    $EOL = "\015\012";

    # Fix to unset the error message of a previous IO::Socket::INET run
    # Thanks to Ben Schnopp <ben at schnopp dot com>
    undef $@;

    # Open socket to proxy server
    my $socket = IO::Socket::INET->new(
        PeerAddr => $proxy,
        Proto    => 'tcp',
        Timeout  => 5,
        Type     => SOCK_STREAM
    );

    # If there was an error, throw an exception
    if ($@) {
        return $self->_throw("Couldn't connect to '$proxy'. $@");
    }
    
    # Set request
    $request = <<"REQUEST";
GET $url HTTP/1.0
Referer: None
User-Agent: $user_agent
Pragma: no-cache

REQUEST

    $request =~ s/\n/\015\012/g;

    # Print request to the open socket
    print $socket $request;
    
    # Read the answer of the proxy server to an array
    while ( defined( $line = <$socket> ) ) {
        $line =~ s/\n//g;
        push @answer, $line;
    }

    $answer = join "\n", @answer;

    # Throw an exception if the answer is empty
    unless ( defined $answer && $answer !~ /^\s*$/ ) {
        return $self->_throw("'$proxy' didn't return anything. Maybe '$proxy' is not the address of a proxy server.");
    }
   
    # Parse the answer according to the requested answer size
    if ( $answer_size eq 'short' ) {
        $answer = $answer[0];
    }
    elsif ( $answer_size eq 'header' ) {
        foreach (@answer) {
            if ( !/^\s*</ && !/^\s+/ ) {
                push @header, $_;
            }
            else {
                last;
            }
        }
        $answer = join "\n", @header;
    }

    # Throw an exception if the parsed answer is empty
    unless ( defined $answer && $answer !~ /^\s*$/ ) {
        return $self->_throw(qq#'$proxy' didn't return a header. Try setting 'answer_size => "full"' as attribute of your 'HTTP::ProxyCheck' object or the 'check()' method. You can also use 'set_answer_size( "full" )'.#);
    }

    close($socket);

    $self->_set_answer($answer);

    return 1;
}

sub get_answer {
    my ($self) = @_;

    unless ( defined $self->{answer} ) {
        return $self->_throw('No answer returned so far.');
    }

    return $self->{answer};
}

sub get_error {
    my ($self) = @_;

    unless ( defined $self->{error} ) {
        return $self->_throw('No error happened so far.');
    }

    return $self->{error};
}

sub get_proxy {
    my ($self) = @_;

    unless ( defined $self->{proxy} ) {
        $self->_throw(
q#No proxy defined. Set it as attribute of your 'HTTP::ProxyCheck' object or with 'set_proxy()'.#
        );
    }

    return $self->{proxy};
}

sub set_proxy {
    my ( $self, $proxy ) = @_;

    unless ( defined $proxy ) {
        return $self->_throw('No proxy server defined.');
    }

    # Check the proxy server address
    unless ( $self->_check_proxy( $proxy, $self->{check_proxy} ) ) {
        return $self->_throw( $self->{error} );
    }

    $self->{proxy} = $proxy;

    return 1;
}

sub get_check_proxy {
    my ($self) = @_;

    return $self->{check_proxy};
}

sub set_check_proxy {
    my ( $self, $check_proxy ) = @_;

    unless ( defined $check_proxy ) {
        return $self->_throw(q#No 'check_proxy' value defined.#);
    }

    # Get boolean value for $check_proxy
    $check_proxy = $self->_get_bool( $check_proxy );
    
    $self->{check_proxy} = $check_proxy;

    return 1;
}

sub get_url {
    my ($self) = @_;

    unless ( defined $self->{url} ) {
        $self->_throw(
q#No url defined. Set it as attribute of your 'HTTP::ProxyCheck' object or with 'set_url()'.#
        );
    }

    return $self->{url};
}

sub set_url {
    my ( $self, $url ) = @_;

    unless ( defined $url ) {
        return $self->_throw('No URL defined.');
    }

    # Check the URL
    unless ( $self->_check_url( $url, $self->{check_url} ) ) {
        return $self->_throw( $self->{error} );
    }

    $self->{url} = $url;

    return 1;
}

sub get_check_url {
    my ($self) = @_;

    return $self->{check_url};
}

sub set_check_url {
    my ( $self, $check_url ) = @_;

    unless ( defined $check_url ) {
        return $self->_throw(q#No 'check_url' value defined.#);
    }

    # Get boolean value for $check_url
    $check_url = $self->_get_bool( $check_url );
    
    $self->{check_url} = $check_url;

    return 1;
}

sub get_answer_size {
    my ($self) = @_;

    unless ( defined $self->{answer_size} ) {
        $self->_throw(
q#No answer size defined. Set it as attribute of your 'HTTP::ProxyCheck' object or with 'set_answer_size()'.#
        );
    }

    return $self->{answer_size};
}

sub set_answer_size {
    my ( $self, $answer_size ) = @_;

    unless ( defined $answer_size ) {
        return $self->_throw('No answer size defined.');
    }

    # Check the answer size
    unless ( $self->_check_answer_size($answer_size) ) {
        return $self->_throw( $self->{error} );
    }

    $self->{answer_size} = $answer_size;

    return 1;
}

#-------------------------------------------------------------------------------
# Private method: _check_proxy()
#-------------------------------------------------------------------------------
# Checks whether a provided proxy server address complies with the pattern 
# 'host:port'.
#
# Attributes
#   * $proxy
#     Defines the proxy server address to check.
#   * $check_proxy
#     Indicates whether to check the proxy server address or not. Possible 
#     values are
#     '1' or '0'.
#
# Return values
#   * Okay
#     1
#   * Error
#     undef
#-------------------------------------------------------------------------------

sub _check_proxy {
    my ( $self, $proxy, $check_proxy ) = @_;

    unless ( defined $proxy ) {
        return undef;
    }

    if ($check_proxy) {

        # Check proxy server address format
        unless ( $proxy =~ /^(\S*):(\d{1,5})$/ ) {
            $self->{error} =
"The specified proxy server '$proxy' doesn't comply with the pattern 'host:port' e.g. 'proxy:8080'.";
            return undef;
        }

        my $proxyhost = $1;
        my $proxyport = $2;

        # Check proxy server host and port
        unless ( Validate::Net->host($proxyhost)
            && Validate::Net->port($proxyport) )
        {
            $self->{error} =
              "The specified proxy server address '$proxy' is invalid. "
              . Validate::Net->reason() . ".";
            return undef;
        }
    }

    return 1;
}

#-------------------------------------------------------------------------------
# Private method: _check_url()
#-------------------------------------------------------------------------------
# Checks whether a provided URL is a valid URL for HTTP::ProxyCheck e.g. 
# 'http://search.cpan.org'.
#
# Attributes
#   * $url
#     Defines the URL to check.
#   * $check_url
#     Indicates whether to check the URL or not. Possible values are '1' or '0'.
#
# Return values
#   * Okay
#     1
#   * Error
#     undef
#-------------------------------------------------------------------------------

sub _check_url {
    my ( $self, $url, $check_url ) = @_;

    unless ( defined $url ) {
        return undef;
    }

    if ($check_url) {

        # Check URL format
        unless ( $url =~ m#^http://([^:/]+)(?::(\d+))?(?:/.*)?# ) {
            $self->{error} =
"The specified URL '$url' doesn't comply with the pattern of a valid URL for HTTP::ProxyCheck e.g. 'http://search.cpan.org'";
            return undef;
        }
        my $host = $1;
        my $port = $2;

        my $invalid_url = "The specified URL '$url' is not valid. ";

        # Check host and port
        unless ( Validate::Net->host($host) ) {
            $self->{error} = $invalid_url . Validate::Net->reason() . ".";
            return undef;
        }

        if ( defined $port ) {
            unless ( Validate::Net->port($port) ) {
                $self->{error} = $invalid_url . Validate::Net->reason() . ".";
                return undef;
            }
        }
    }

    return 1;
}

#-------------------------------------------------------------------------------
# Private method: _check_answer_size()
#-------------------------------------------------------------------------------
# Checks whethera provided answer size is valid.
#
# Attributes
#   * $answer_size
#     Specifies the answer size. Possible values are 'short', 'header' or 
#     'full'.
#
# Return values
#   * Okay
#     1
#   * Error
#     undef
#-------------------------------------------------------------------------------

sub _check_answer_size {
    my ( $self, $answer_size ) = @_;

    unless ( defined $answer_size ) {
        return undef;
    }

    # The answer size must be either 'short', 'header' or 'full'
    unless ( $answer_size =~ m/^short|header|full$/ ) {
        $self->{error} =
"The specified answer size '$answer_size' is invalid, use either 'header' or 'full'.";
        return undef;
    }

    return 1;
}

#-------------------------------------------------------------------------------
# Private method: _throw()
#-------------------------------------------------------------------------------
# Throws an exeption with a message and optional with a specified return code.
# If no return code is specified, 'undef' is returned.
#
# Attributes
#   * $message
#     Defines the error message.
#   * $return_code
#     Specifies an optional return code for scalar context (default is 'undef').
#     In list context, '()' (empty list) is used.
#
# Return values
#   * Okay
#       * Array context
#         () (empty list)
#       * Scalar context
#         $return_code
#-------------------------------------------------------------------------------

sub _throw {
    my ( $self, $message, $return_code ) = @_;

    unless ( defined $return_code ) {
        $return_code = undef;
    }

    # Get the method name
    my $method = ( caller 1 )[3];

    # If the verbose errors attribut is set, add 'method_name failed:' to the 
    # error message
    if ( $self->{verbose_errors} ) {
        $message = "$method failed: " . $message;
    }

    $self->_set_error($message);

    # Throw the exception
    Carp::croak $self->{error} if $self->{raise_error};
    Carp::carp $self->{error}  if $self->{print_error};

    # Return the return code in the right context
    if (wantarray) {
        return ();
    }
    else {
        return $return_code;
    }
}

#-------------------------------------------------------------------------------
# Private method: _set_error()
#-------------------------------------------------------------------------------
# Sets $self->{error} and $error and returns the previous error message.
#
# Attributes
#   * $my_error
#     Defines the error message.
#
# Return values
#   * Okay
#     $prev_error
#   * Error
#     undef
#-------------------------------------------------------------------------------

sub _set_error {
    my ( $self, $my_error ) = @_;
    my $prev_error = $self->{error};

    unless ( defined $my_error ) {
        return undef;
    }

    $self->{error} = $my_error;
    $error = $my_error;

    return $prev_error;
}

#-------------------------------------------------------------------------------
# Private method: _set_answer()
#-------------------------------------------------------------------------------
# Sets $self->{answer} and $answer and returns the previous answer.
#
# Attributes
#   * $my_answer
#     Defines the proxy server answer.
#
# Return values
#   * Okay
#     $prev_answer
#   * Error
#     undef
#-------------------------------------------------------------------------------

sub _set_answer {
    my ( $self, $my_answer ) = @_;
    my $prev_answer = $self->{answer};

    unless ( defined $my_answer ) {
        return undef;
    }

    $self->{answer} = $my_answer;
    $answer = $my_answer;

    return $prev_answer;
}

#-------------------------------------------------------------------------------
# Private method: _get_bool()
#-------------------------------------------------------------------------------
# Translates values to boolean value. '0' remains '0', 'undef' is translated to
# the default value and every other value is gets '1'.
#
# Attributes
#   * $value
#     Specifies the value to translate.
#   * $default
#     Defines the default value for undefined values.
#
# Return values
#   * True
#     1
#   * False
#     0
#-------------------------------------------------------------------------------

sub _get_bool {
    my ( $self, $value, $default ) = @_;

    # Check and set $default
    if ( defined $default ) {
        unless ( $default eq 0 ) {
            $default = 1;
        }
    }
    else {
        $default = 1;
    }

    # Check and set $value
    if ( defined $value ) {
        unless ( $value eq 0 ) {
            $value = 1;
        }
    }
    else {
        $value = $default;
    }

    return $value;
}

#-------------------------------------------------------------------------------
# Private method: _init()
#-------------------------------------------------------------------------------
# Initializes the default values of the attributes of new().
#
# Return values
#   * Okay
#     1
#   * Error
#     undef
#-------------------------------------------------------------------------------

sub _init {
    my ($self) = @_;
    my $verbose_errors = $self->{verbose_errors};
    my $print_error    = $self->{print_error};
    my $raise_error    = $self->{raise_error};
    my $check_proxy    = $self->{check_proxy};
    my $check_url      = $self->{check_url};
    my $proxy          = $self->{proxy};
    my $url            = $self->{url};
    my $answer_size    = $self->{answer_size};

    # Set the verbose errors attribute
    $self->{verbose_errors} = $self->_get_bool( $verbose_errors, 0 );

    # Set the print error attribute
    $self->{print_error} = $self->_get_bool( $print_error, 1 );

    # Set the raise error attribute
    $self->{raise_error} = $self->_get_bool( $raise_error, 0 );

    # Set the check proxy attribute
    $self->{check_proxy} = $self->_get_bool( $check_proxy, 1 );

    # Set the check URL attribute
    $self->{check_url} = $self->_get_bool( $check_url, 1 );

    # Check the proxy server address
    if ( defined $proxy ) {
        unless ( $self->_check_proxy( $proxy, $self->{check_proxy} ) ) {
            return undef;
        }
        $self->{proxy} = $proxy;
    }

    # Check the URL
    if ( defined $url ) {
        unless ( $self->_check_url( $url, $self->{check_url} ) ) {
            return undef;
        }
        $self->{url} = $url;
    }

    # Check the answer size
    if ( defined $answer_size ) {
        unless ( $self->_check_answer_size($answer_size) ) {
            return undef;
        }
    }
    else {
        $answer_size = 'header';
    }
    $self->{answer_size} = $answer_size;

    return 1;
}

1;

__END__