File Coverage

blib/lib/Gantry/Control/C/Access.pm

Criterion	Covered	Total	%
statement	10	69	14.4
branch	0	34	0.0
condition	1	3	33.3
subroutine	4	10	40.0
pod	2	2	100.0
total	17	118	14.4

package Gantry::Control::C::Access;

use strict;

use constant MP2 => (
    exists $ENV{MOD_PERL_API_VERSION} and
    $ENV{MOD_PERL_API_VERSION} >= 2
);

# must explicitly import for mod_perl2
BEGIN {
    if (MP2) {
        require Gantry::Engine::MP20;
        Gantry::Engine::MP20->import();
    }
}

############################################################
# Functions                                                #
############################################################

######################################################################
# Main Execution Begins Here                                         #
######################################################################
sub handler : method {
    my( $self, $r ) = @_;

    my $remote_ip = $self->remote_ip( $r );

    # Range, or specfic ips.
    my $ranges  = $r->dir_config( 'AuthAllowRanges' );

    if ( defined $r->dir_config( 'auth_allow_ranges' ) ) {
        $ranges = $r->dir_config( 'auth_allow_ranges' );
    }

    my $ips = $r->dir_config( 'AuthAllowIps' );

    if ( defined $r->dir_config( 'auth_allow_ips' ) ) {
        $ips = $r->dir_config( 'auth_allow_ips' );
    }

    my $ignore = $r->dir_config( 'AccessNoOverRide' );

    if ( defined $r->dir_config( 'ignore_access_handler' ) ) {
        if ( $r->dir_config( 'ignore_access_handler' ) =~/^y/i ) {
            $ignore = 1;
        }
        elsif ( $r->dir_config( 'ignore_access_handler' ) =~ /^n/i ) {
            $ignore = 0;
        }
    }

    $ignore     = 0 if ( ! defined $ignore );

    if ( defined $ranges ) {
        # make the decimal version of the ip.

        my @remote = split( '\.', $remote_ip );

        my $dip = ip2bin( $remote[0] );
        $dip    .= ip2bin( $remote[1] );
        $dip    .= ip2bin( $remote[2] );
        $dip    .= ip2bin( $remote[3] );

        # This is broken in 5.05
        #my $dip1 = sprintf( "%08b %08b %08b %08b", split( '\.', $remote_ip ));

        for my $range ( split( ',', $ranges ) ) {
            my ( $ranged, $slash ) = $range =~ /^(.*)\/(\d+)$/;

            my @ranger  = split( '\.', $ranged );
            my $drng    = ip2bin( $ranger[0] );
            $drng       .= ip2bin( $ranger[1] );
            $drng       .= ip2bin( $ranger[2] );
            $drng       .= ip2bin( $ranger[3] );

            # This is broken in 5.05
            #my $drng = sprintf( "%08b%08b%08b%08b", split( '\.', $ranged ) );

            if ( substr( $dip, 0, $slash) eq substr( $drng, 0, $slash ) ) {

                if ( ! $r->user ) {
                    $r->user( 'anoymous_ip_user' );
                }

                if ( ! $ignore ) {
                    $r->set_handlers( PerlAuthenHandler => [
                        sub{ $self->status_const( 'OK' ) }
                    ] );
                    $r->set_handlers( PerlAuthzHandler  => [
                        sub{ $self->status_const( 'OK' ) } ] );
                }

                return( $self->status_const( 'OK' ) );
            }
        }
    }

    if ( defined $ips ) {
        for my $ip ( split( ',', $ips ) ) {
            if ( $ip =~ /^\s?$remote_ip\s?$/ ) {
                if ( ! $r->user ) {
                    $r->user( 'anoymous_ip_user' );
                }

                if ( ! $ignore ) {
                    $r->set_handlers( PerlAuthenHandler => [
                        sub{ $self->status_const( 'OK' ) }
                    ] );
                    $r->set_handlers( PerlAuthzHandler  => [
                        sub{ $self->status_const( 'OK' ) } ] );
                }

                return( $self->status_const( 'OK' ) );
            }
        }
    }

    return( $self->status_const( 'DECLINED' ) );

} # END handler

#-------------------------------------------------
# ip2bin( $ip )
#-------------------------------------------------
# dec 2 bin for the ip address.
#-------------------------------------------------
sub ip2bin {
    my $dec = shift;

    my $bin = unpack( "B32", pack( "N", $dec ) );
    $bin    =~ s/^0+(?=\d)//;

    if ( length( $bin ) < 8 ) {
        return( '0' x ( 8 - length( $bin ) ) . $bin );
    }
    else {
        return( $bin );
    }
} # END ip2bin

#-------------------------------------------------
# $self->import(  @options )
#-------------------------------------------------
sub import {
    my ( $self, @options ) = @_;

    my( $engine, $tplugin );

    foreach (@options) {

        # Import the proper engine
        if (/^-Engine=(.*)$/) {
            $engine = "Gantry::Engine::$1";
            eval "use $engine";
            if ( $@ ) {
                die "unable to load engine $1 ($@)";
            }
        }

    }

} # end: import

# EOF
1;

__END__