File Coverage

blib/lib/ModPerl/ParamBuilder.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package ModPerl::ParamBuilder;
#####################################################################
#
# Module      : ModPerl::ParamBuilder
# Author      : Frank Wiles
#
# Description : This module is a wrapper that assists in making/using
#               custom Apache directives easier for the most common
#               use cases.
#
#####################################################################

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

use Carp qw( croak );

use Apache2::CmdParms ();
use Apache2::Module ();
use Apache2::ServerUtil ();

###########################################################
# Variables                                               #
###########################################################
$VERSION        =   '0.08';

###########################################################
# Methods                                                 #
###########################################################

#------------------------------------------------
# new( __PACKAGE__ )
#------------------------------------------------
# Object constructor
#------------------------------------------------
sub new {
    my $class       = shift;
    my $package     = shift;

    # For use when retrieving the configuration
    if( !defined( $package ) and $class !~ /^ModPerl::ParamBuilder/o ) {
        $package = $class;
    }

    # Make sure we receive a package name
    croak( 'No package defined in new() ' . caller . ' ' . $class )
        if ( !defined( $package ) or $package eq '' );

    my $self = {};

    # In what namespace we are going to install these directives in
    $$self{_calling_package} = $package;

    # Array to hold our directives
    $$self{_directives}      = [];

    # Objectify this hash :)
    bless( $self, $class );

    return( $self );

} # END new

#------------------------------------------------
# _build_param
#------------------------------------------------
# This the main meat of this module. It builds
# up our @{ $self{_directives} } array that we
# pass to Apache2::Module::add() to actually
# install them
#------------------------------------------------
sub _build_param {
    my $self        =   shift;
    my $opts        =   shift;

    # Ensure we have some options and do some basic error checking
    croak( 'No options passed to ModPerl::ParamBuilder::_build_param() ' )
        if ( keys( %{$opts} ) < 1 );

    # Make sure we have a name
    croak( ' \'name\' must be defined in order to build paramater ' )
        if !exists( $$opts{name} );

    # Hash used in building the directives array
    my $tmp_hash = {};
    $$tmp_hash{ 'name' }  = $$opts{name};

    # The hash key defaults to the name of the directive or
    # the user can override it by passing a 'key' to use
    if( !exists( $$opts{key} ) or $$opts{key} eq '' ) {
        $$tmp_hash{ 'cmd_data' } = $$opts{name};
    }
    else {
        $$tmp_hash{ 'cmd_data' } = $$opts{key};
    }

    # Pass along our error message if there is one
    if( exists( $$opts{err} ) ) {
        $$tmp_hash{ 'errmsg' } = $$opts{err};
    }

    # Determine what type of take we are
    $$tmp_hash{ 'args_how' } = $self->_determine_take( $$opts{take} );

    # Set a function if we aren't given one explicitly
    if( !exists($$opts{func}) or $$opts{func} eq '' ) {
        $$tmp_hash{ 'func' } = $self->_determine_func($$tmp_hash{'args_how'});
    }
    else {
        $$tmp_hash{ 'func' } = $$opts{func};
    }

    # Store this directive for later loading
    push( @{ $self->{_directives} }, $tmp_hash );

} # END _build_param

#------------------------------------------------
# _determine_take
#------------------------------------------------
# Figure out what options we need to take
#------------------------------------------------
sub _determine_take {
    my $self        =   shift;
    my $take        =   shift;
    my $tmp_value   =   'Apache2::Const::';  # Variable to return to caller

    # We've already explicitly set it, so don't bother trying to
    # determine it
    return( $take ) if ( $take and $take =~ /^Apache2::Const::/o );

    # Default to one argument
    if( !defined( $take ) or $take eq '' ) {
        return( $tmp_value . 'TAKE1' );
    }

    # Translate any words to numbers
    if( $take !~ /^\d+$/o ) {
        $tmp_value .= 'TAKE1'    if $take eq 'one';
        $tmp_value .= 'TAKE2'    if $take eq 'two';
        $tmp_value .= 'TAKE3'    if $take eq 'three';
        $tmp_value .= 'TAKE12'   if $take eq 'one_plus';
        $tmp_value .= 'TAKE23'   if $take eq 'two_plus';
        $tmp_value .= 'TAKE123'  if $take eq 'one_plus_two';
        $tmp_value .= 'ITERATE'  if $take eq 'list';
        $tmp_value .= 'ITERATE2' if $take eq 'one_plus_list';
    }
    else {
        $tmp_value .= 'TAKE' . $take;
    }

    return( $tmp_value );

} # END _determine_take

#------------------------------------------------
# _determine_func
#------------------------------------------------
# This function determines which function we
# should use for processing the directive's
# values.  It uses the already determined take
# for this. NOTE: This must be called after
# _determine_take to work properly
#------------------------------------------------
sub _determine_func {
    my $self        =   shift;
    my $arg         =   shift;

    # Make sure we're given an argument
    croak( 'No argument given to _determine_func method' )
        if ( !defined( $arg ) or $arg eq '' );

    # Clean up our argument for easier processing
    $arg =~ s/^Apache2::Const:://o;

    return( __PACKAGE__ . '::Handle_TAKE1'    ) if $arg eq 'TAKE1';
    return( __PACKAGE__ . '::Handle_TAKE2'    ) if $arg eq 'TAKE2';
    return( __PACKAGE__ . '::Handle_TAKE3'    ) if $arg eq 'TAKE3';
    return( __PACKAGE__ . '::Handle_TAKE12'   ) if $arg eq 'TAKE12';
    return( __PACKAGE__ . '::Handle_TAKE23'   ) if $arg eq 'TAKE23';
    return( __PACKAGE__ . '::Handle_TAKE123'  ) if $arg eq 'TAKE123';
    return( __PACKAGE__ . '::Handle_ITERATE'  ) if $arg eq 'ITERATE';
    return( __PACKAGE__ . '::Handle_ITERATE2' ) if $arg eq 'ITERATE2';

} # END _determine_func

#------------------------------------------------
# param
#------------------------------------------------
# Build a directive based on user args
#------------------------------------------------
sub param {
    my $self        =   shift;
    my $arg         =   shift;

    # Make sure we're given something
    croak( 'No arguments provided to param() method' )
        if ( !$arg or $arg eq '' );

    # We either take a simple directive name or a hash of
    # options for the directive
    if( ref($arg) ne 'HASH' ) {
        $self->_build_param( { name => $arg } );
    }
    else {
        $self->_build_param( $arg );
    }

    return;

} # END param

#------------------------------------------------
# no_arg
#------------------------------------------------
# This builds a directive that takes no arguments
# and is simply incremented when it is used
#------------------------------------------------
sub no_arg {
    my $self        =   shift;
    my $arg         =   shift;

    # Make sure we're given a name
    croak( 'No arguments provided to no_arg() method' )
        if ( !$arg or $arg eq '' );

    # Build it
    my $tmp_hash = {};
    $$tmp_hash{ 'take' } = 'Apache2::Const::NO_ARGS';
    $$tmp_hash{ 'func' } = __PACKAGE__ . '::Handle_NO_ARGS';

    # Merge in any user overrides
    if( ref( $arg ) eq 'HASH' ) {
        $$tmp_hash{ 'name' } = $$arg{ 'name' };

        $$tmp_hash{ 'err' } = $$arg{ 'err' } if $$arg{ 'err' };
        $$tmp_hash{ 'key' } = $$arg{ 'key' } if $$arg{ 'key' };
    }
    else {
        $$tmp_hash{ 'name' } = $arg;
    }

    # Actually build the parameter
    $self->_build_param( $tmp_hash );

} # END no_arg

#------------------------------------------------
# on_off
#------------------------------------------------
# This builds a flag that is either On or Off
#------------------------------------------------
sub on_off {
    my $self        =   shift;
    my $arg         =   shift;

    # Make sure we're given something
    croak( 'No arguments provided to on_off() method' )
        if ( !$arg or $arg eq '' );

    # Build our our args for _build_param
    my $tmp_hash = {};
    $$tmp_hash{ 'take' } = 'Apache2::Const::FLAG';
    $$tmp_hash{ 'func' } = $self->{_calling_package} . '::Handle_On_Off';

    if( ref( $arg ) eq 'HASH' ) {

        $$tmp_hash{ 'name' } = $$arg{'name'};
        $$tmp_hash{ 'err'  } = $$arg{'err'} if $$arg{'err'};
        $$tmp_hash{ 'key'  } = $$arg{'key'} if $$arg{'key'};

    }
    else {
        $$tmp_hash{ 'name' } = $arg;
    }

    # Build the directive
    $self->_build_param( $tmp_hash );

} # END flag

#------------------------------------------------
# yes_no
#------------------------------------------------
# This builds a simple argument that takes a
# Yes or No as it's argument
#------------------------------------------------
sub yes_no {
    my $self        =   shift;
    my $arg         =   shift;

    # Make sure we're given a name
    croak( 'No arguments provided to yes_no() method' )
        if ( !$arg or $arg eq '' );

    # Build our our args for _build_param
    my $tmp_hash = {};
    $$tmp_hash{ 'take' } = 'Apache2::Const::TAKE1';
    $$tmp_hash{ 'func' } = $self->{_calling_package} . '::Handle_Yes_No';

    if( ref( $arg ) eq 'HASH' ) {

        $$tmp_hash{ 'name' } = $$arg{'name'};
        $$tmp_hash{ 'err'  } = $$arg{'err'} if $$arg{'err'};
        $$tmp_hash{ 'key'  } = $$arg{'key'} if $$arg{'key'};

    }
    else {
        $$tmp_hash{ 'name' } = $arg;
    }

    # Build the directive
    $self->_build_param( $tmp_hash );

} # END yes_no

#------------------------------------------------
# load
#------------------------------------------------
# Install the newly built directives
#------------------------------------------------
sub load {
    my $self        =   shift;

    # Die if we don't have anything to build
    if( scalar( @{ $self->{_directives} } ) < 1 ) {
        croak "No Apache directives defined: $!";
    }

    use Data::Dumper;
    warn( "Loading..." );
    warn( Dumper( $self->{_directives} ) );

    # Actually load them
    Apache2::Module::add(   $self->{_calling_package},
                            \@{ $self->{_directives} } );

} # END load

#------------------------------------------------
# get_config
#------------------------------------------------
# This method retrieves the configuration for
# this module
#------------------------------------------------
sub get_config {
    my $self        =   shift;
    my $r           =   shift;

    # Use the caller when retrieving from outside of the derived
    # class
    if( !defined($self) ) {
        $self = caller;
    }

    # Use the $r we are given, but if we're not given one
    # attempt to get the global one, provided the user has
    # +GlobalRequest on
    if( !defined($r) ) {

        use Apache2::RequestUtil ();

        # Retrieve global request
        $r = Apache2::RequestUtil->request or
            croak   'No request object given to get_config() and '.
                    'PerlOptions +GlobalRequest not set, unable to '.
                    'retrieve configuration without request object'
    }

    # Retrieve the actual configuration
    no strict 'refs';
    my $return_value = Apache2::Module::get_config(
                                                    $self->{_calling_package},
                                                    $r->server,
                                                    $r->per_dir_config );

    return( $return_value );

} # END get_config

#####################################################################
# Below are the functions used to process the arguments of the
# directives
#####################################################################

#------------------------------------------------
# Handle_TAKE1
#------------------------------------------------
sub Handle_TAKE1 {
    my ($self, $parms, $arg) = @_;

    $self->{ $parms->info } = $arg;

} # END HANDLE_TAKE1

#------------------------------------------------
# Handle_TAKE2
#------------------------------------------------
sub Handle_TAKE2 {
    my ($self, $parms, $arg1, $arg2) = @_;

    $self->{ $parms->info } = { arg1 => $arg1, arg2 => $arg2 };

} # END HANDLE_TAKE2

#------------------------------------------------
# Handle_TAKE3
#------------------------------------------------
sub Handle_TAKE3 {
    my ($self, $parms, $arg1, $arg2, $arg3) = @_;

    $self->{ $parms->info } = { arg1 => $arg1, arg2 => $arg2, arg3 => $arg3 };

} # END HANDLE_TAKE3

#------------------------------------------------
# Handle_TAKE12
#------------------------------------------------
sub Handle_TAKE12 {
    my ($self, $parms, $arg1, $arg2) = @_;

    $self->{ $parms->info } = { arg1 => $arg1, arg2 => $arg2 };

} # END HANDLE_TAKE12

#------------------------------------------------
# Handle_TAKE23
#------------------------------------------------
sub Handle_TAKE23 {
    my ($self, $parms, $arg1, $arg2, $arg3) = @_;

    $self->{ $parms->info } = { arg1 => $arg1, arg2 => $arg2, arg3 => $arg3 };

} # END HANDLE_TAKE23

#------------------------------------------------
# Handle_TAKE123
#------------------------------------------------
sub Handle_TAKE123 {
    my ($self, $parms, $arg1, $arg2, $arg3) = @_;

    $self->{ $parms->info } = { arg1 => $arg1, arg2 => $arg2, arg3 => $arg3 };

} # END HANDLE_TAKE123

#------------------------------------------------
# Handle_ITERATE
#------------------------------------------------
# Handle a list
#------------------------------------------------
sub Handle_ITERATE {
    my ($self, $parms, $arg) = @_;

    if( !exists( $self->{ $parms->info } ) ) {
        $self->{ $parms->info } = [];
    }

    push( @{ $self->{ $parms->info } }, $arg );

} # END HANDLE_ITERATE

#------------------------------------------------
# Handle_ITERATE2
#------------------------------------------------
# Handle a default and a list
#------------------------------------------------
sub Handle_ITERATE2 {
    my ($self, $parms, $key, $val) = @_;

    push( @{ $self->{ $parms->info }{ $key } }, $val );

} # END HANDLE_ITERATE2

#------------------------------------------------
# Handle_NO_ARGS
#------------------------------------------------
sub Handle_NO_ARGS {
    my ($self, $parms) = @_;

    $self->{ $parms->info }++;

} # END HANDLE_NO_ARGS

#------------------------------------------------
# Handle_On_Off
#------------------------------------------------
sub Handle_On_Off {
    my ($self, $parms, $arg) = @_;

    $self->{ $parms->info } = $arg;

} # END HANDLE_On_Off

#------------------------------------------------
# Handle_Yes_No
#------------------------------------------------
sub Handle_Yes_No {
    my ($self, $parms, $arg) = @_;

    if( $arg =~ /yes/io ) {
        $arg = 1;
    }
    else {
        $arg = 0;
    }

    $self->{ $parms->info } = $arg;

} # END HANDLE_Yes_No

# EOF
1;

__END__