lw2.pm

Ubuntu packages of security software。 相当不错的源码

#!/usr/bin/perl
# LW2 version 2.4
#
#  LW2 copyright 2000-2006 by rain forest puppy, rfp.labs
#
#  This program is free software; you can redistribute it and/or
#  modify it under the terms of the GNU General Public License
#  as published by the Free Software Foundation; either version 2
#  of the License, or (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

=head1 NAME

LW2 - Perl HTTP library version 2.4

=head1 SYNOPSIS

use LW2;

require 'LW2.pm';

=head1 DESCRIPTION

Libwhisker is a Perl library useful for HTTP testing scripts.  It
contains a pure-Perl reimplementation of functionality found in the C<LWP>,
C<URI>, C<Digest::MD5>, C<Digest::MD4>, C<Data::Dumper>, C<Authen::NTLM>, 
C<HTML::Parser>, C<HTML::FormParser>, C<CGI::Upload>, C<MIME::Base64>,
and C<GetOpt::Std> modules.

Libwhisker is designed to be portable (a single perl file), fast (general
benchmarks show libwhisker is faster than LWP), and flexible (great care
was taken to ensure the library does exactly what you want to do, even
if it means breaking the protocol).

=head1 FUNCTIONS

The following are the functions contained in Libwhisker:

=over 4

=cut


package LW2;
$LW2::VERSION="2.4";
$PACKAGE='LW2';

BEGIN {
package LW2;
$PACKAGE='LW2';
    ## LW module manager stuff ##

    $LW_SSL_LIB          = 0;
    $LW_SSL_KEEPALIVE    = 0;
    $LW_NONBLOCK_CONNECT = 1;

    $_SSL_LIBRARY = undef;

    eval "use Socket";
    if ( !$@ ) {
        eval "use Net::SSLeay";    # do we have SSL support?
        if ( !$@ ) {
            $LW_SSL_LIB   = 1;
            $_SSL_LIBRARY = 'Net::SSLeay';
            Net::SSLeay::load_error_strings();
            Net::SSLeay::SSLeay_add_ssl_algorithms();
            Net::SSLeay::randomize();

        }
        else {
            eval "use Net::SSL";
            if ( !$@ ) {
                $LW_SSL_LIB   = 2;
                $_SSL_LIBRARY = 'Net::SSL';
            }
        }

        if ( $^O !~ /Win32/ ) {
            eval "use POSIX qw(:errno_h :fcntl_h)";
            if ($@) { $LW_NONBLOCK_CONNECT = 0; }
        }
        else {

            # taken from Winsock2.h
            *EINPROGRESS = sub { 10036 };
            *EWOULDBLOCK = sub { 10035 };
        }
    }

} # BEGIN


########################################################################

=item B<auth_brute_force>

Params: $auth_method, \%req, $user, \@passwords [, $domain, $fail_code ]

Return: $first_valid_password, undef if error/none found

Perform a HTTP authentication brute force against a server (host and URI 
defined in %req).  It will try every password in the password array for 
the given user.  The first password (in conjunction with the given user) 
that doesn't return HTTP 401 is returned (and the brute force is stopped 
at that point).  You should retry the request with the given password and
double-check that you got a useful HTTP return code that indicates
successful authentication (200, 302), and not something a bit more 
abnormal (407, 500, etc).  $domain is optional, and is only used for NTLM
auth.

Note: set up any proxy settings and proxy auth in %req before calling
this function.

You can brute-force proxy authentication by setting up the target proxy
as proxy_host and proxy_port in %req, using an arbitrary host and uri
(preferably one that is reachable upon successful proxy authorization),
and setting the $fail_code to 407.  The $auth_method passed to this
function should be a proxy-based one ('proxy-basic', 'proxy-ntlm', etc).

if your server returns something other than 401 upon auth failure, then
set $fail_code to whatever is returned (and it needs to be something
*different* than what is received on auth success, or this function
won't be able to tell the difference).

=cut

sub auth_brute_force {
    my ( $auth_method, $hrin, $user, $pwordref, $dom, $fail_code ) = @_;
    my ( $P, %hout );
    $fail_code ||= 401;

    return undef if ( !defined $auth_method || length($auth_method) == 0 );
    return undef if ( !defined $user        || length($user) == 0 );
    return undef if ( !( defined $hrin     && ref($hrin) ) );
    return undef if ( !( defined $pwordref && ref($pwordref) ) );

    map {
        ( $P = $_ ) =~ tr/\r\n//d;
        auth_set_header( $auth_method, $hrin, $user, $P, $dom );
        return undef if ( http_do_request( $hrin, \%hout ) );
        return $P if ( $hout{whisker}->{code} != $fail_code );
    } @$pwordref;

    return undef;
}

########################################################################

=item B<auth_unset>

Params: \%req

Return: nothing (modifies %req)

Modifes %req to disable all authentication (regular and proxy).

Note: it only removes the values set by auth_set().  Manually-defined
[Proxy-]Authorization headers will also be deleted (but you shouldn't 
be using the auth_* functions if you're manually handling your own auth...)

=cut

sub auth_unset {
    my $href = shift;
    return if ( !defined $href || !ref($href) );
    delete $$href{Authorization};
    delete $$href{'Proxy-Authorization'};
    delete $$href{whisker}->{auth_callback};
    delete $$href{whisker}->{auth_proxy_callback};
    delete $$href{whisker}->{auth_data};
    delete $$href{whisker}->{auth_proxy_data};
}

########################################################################

=item B<auth_set>

Params: $auth_method, \%req, $user, $password [, $domain]

Return: nothing (modifies %req)

Modifes %req to use the indicated authentication info.

Auth_method can be: 'basic', 'proxy-basic', 'ntlm', 'proxy-ntlm'.

Note: this function may not necessarily set any headers after being called.
Also, proxy-ntlm with SSL is not currently supported.

=cut

sub auth_set {
    my ( $method, $href, $user, $pass, $domain ) = ( lc(shift), @_ );

    return if ( !( defined $href && ref($href) ) );
    return if ( !defined $user || !defined $pass );

    if ( $method eq 'basic' ) {
        $$href{'Authorization'} =
          'Basic ' . encode_base64( $user . ':' . $pass, '' );
    }

    if ( $method eq 'proxy-basic' ) {
        $$href{'Proxy-Authorization'} =
          'Basic ' . encode_base64( $user . ':' . $pass, '' );
    }

    if ( $method eq 'ntlm' ) {
        http_close($href);
        $$href{whisker}->{auth_data} = ntlm_new( $user, $pass, $domain );
        $$href{whisker}->{auth_callback} = \&_ntlm_auth_callback;
    }

    if ( $method eq 'proxy-ntlm' ) {
        utils_croak('',"auth_set: proxy-ntlm auth w/ SSL not currently supported")
          if ( $href->{whisker}->{ssl} > 0 );
        http_close($href);
        $$href{whisker}->{auth_proxy_data} = ntlm_new( $user, $pass, $domain );
        $$href{whisker}->{auth_proxy_callback} = \&_ntlm_auth_proxy_callback;
    }

}


########################################################################

=item B<cookie_new_jar>

Params: none

Return: $jar

Create a new cookie jar, for use with the other functions.  Even though
the jar is technically just a hash, you should still use this function
in order to be future-compatible (should the jar format change).

=cut

sub cookie_new_jar {
    return {};
}

########################################################################

=item B<cookie_read>

Params: $jar, \%response [, \%request, $reject ]

Return: $num_of_cookies_read

Read in cookies from an %response hash, and put them in $jar.

Notice: cookie_read uses internal magic done by http_do_request
in order to read cookies regardless of 'Set-Cookie[2]' header
appearance.

If the optional %request hash is supplied, then it will be used to
calculate default host and path values, in case the cookie doesn't
specify them explicitly.  If $reject is set to 1, then the %request
hash values are used to calculate and reject cookies which are not
appropriate for the path and domains of the given request.

=cut

sub cookie_read {
    my ( $count, $jarref, $hrs, $hrq, $rej ) = ( 0, @_ );

    return 0 if ( !( defined $jarref && ref($jarref) ) );
    return 0 if ( !( defined $hrs   && ref($hrs) ) );
    return 0
      if (
        !(
            defined $$hrs{whisker}->{cookies}
            && ref( $$hrs{whisker}->{cookies} )
        )
      );

		my @opt;
		if(defined $hrq && ref($hrq)){
			push @opt, $hrq->{whisker}->{host};
			my $u = $hrq->{whisker}->{uri};
			$u=~s#/.*?$##;
			$u='/' if($u eq '');
			push @opt, $u, $rej;
		}

    foreach ( @{ $hrs->{whisker}->{cookies} } ) {
        cookie_parse( $jarref, $_ , @opt);
        $count++;
    }
    return $count;
}

########################################################################

=item B<cookie_parse>

Params: $jar, $cookie [, $default_domain, $default_path, $reject ]

Return: nothing

Parses the cookie into the various parts and then sets the appropriate 
values in the cookie $jar. If the cookie value is blank, it will delete 
it from the $jar.  See the 'docs/cookies.txt' document for a full
explanation of how Libwhisker parses cookies and what RFC aspects are 
supported.

The optional $default_domain value is taken literally.  Values with no 
leading dot (e.g. 'www.host.com') are considered to be strict hostnames 
and will only match the identical hostname.  Values with leading dots (e.g. 
'.host.com') are treated as sub-domain matches for a single domain level.
If the cookie does not indicate a domain, and a $default_domain is not
provided, then the cookie is considered to match all domains/hosts.

The optional $default_path is used when the cookie does not specify a path.
$default_path must be absolute (start with '/'), or it will be ignored.  If
the cookie does not specify a path, and $default_path is not provided, then
the default value '/' will be used.

Set $reject to 1 if you wish to reject cookies based upon the provided
$default_domain and $default_path.  Note that $default_domain and 
$default_path must be specified for $reject to actually do something 
meaningful.

=cut

sub cookie_parse {
    my ( $jarref, $header ) = (shift, shift);
		my ( $Dd, $Dp, $R ) = (shift, shift, shift||0);

    return if ( !( defined $jarref && ref($jarref) ) );
    return if ( !( defined $header && length($header) > 0 ) );

		my @C = ( undef, undef, undef, undef, 0 );

		$header =~ tr/\r\n//d;
		my ($f,%seen,$n,$t) = (1);
    while( length($header) ){
    	$header =~ s/^[ \t]+//;
    	last if(!($header =~ s/^([^ \t=;]+)//));
    	my $an = lc($1);
			my $av = undef;
    	$header =~ s/^[ \t]+//;
    	if(substr($header,0,1) eq '='){
    		$header=~s/^=[ \t]*//;
    		if(substr($header,0,1) eq '"'){
    			my $p = index($header,'"',1);
    			last if($p == -1);
    			$av = substr($header,1,$p-1);
    			substr($header,0,$p+1)='';
    		} else {
					$av = $1 if($header =~ s/^([^ \t;,]*)//);
    		}
    	} else {
    		my $p = index($header,';');
    		substr($header,0,$p)='';
    	}
    	$header =~ s/^.*?;//;
			if($f){
				return if(!defined $av);
				($f,$n,$C[0])=(0,$an,$av);
			} else {
				$seen{$an}=$av if(!exists $seen{$an});
  		}
    }

		return if(!defined $n || $n eq '');
		my $del = 0;
		$del++ if($C[0] eq '');
		$del++ if(defined $seen{'max-age'} && $seen{'max-age'} eq '0');
		if($del){
        delete $$jarref{$n} if exists $$jarref{$n};			
        return;
		}

		if(defined $seen{domain} && $seen{domain} ne ''){
			$t = $seen{domain};
			$t='.'.$t if(substr($t,0,1) ne '.' && !_is_ip_address($t));
		} else {
			$t=$Dd;
		}
		$t=~s/\.+$// if(defined $t);
		$C[1]=$t;

		if(defined $seen{path}){
			$t = $seen{path};
		} else {
			$t=$Dp || '/';
		}
		$t=~s#/+$##;
		$t='/' if(substr($t,0,1) ne '/');
		$C[2]=$t;

		$C[4]=1 if(exists $seen{secure});

		return if($R && !_is_valid_cookie_match($C[1], $C[2], $Dd, $Dp));
    $$jarref{$n} = \@C;
}

########################################################################

sub _is_ip_address {
	my $n = shift;
	return 1 if($n=~/^[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}$/);
	return 0;
}

sub _is_valid_cookie_match {
	my ($cd, $cp, $td, $tp) = @_;
	return 0 if(index($tp,$cp)!=0);
	if(substr($cd,0,1) eq '.'){
		if( $td =~ /(.+)$cd$/ ){
			return 1 if(index($1,'.') == -1);
		}
		return 0;
	} else {
		return 0 if($cd ne $td);
	}
	return 1;
}

########################################################################