File Coverage

blib/lib/CGI/Application/Muto.pm

Criterion	Covered	Total	%
statement	40	48	83.3
branch			n/a
condition			n/a
subroutine	14	15	93.3
pod			n/a
total	54	63	85.7

package CGI::Application::Muto;

use base 'CGI::Application';

use strict;
use warnings;

use vars '$VERSION';
$VERSION = '0.02';

# Load our recommended plugins
use CGI::Application::Plugin::DBH qw/dbh_config dbh/;
use CGI::Application::Plugin::ConfigAuto qw/cfg_file cfg/;
use CGI::Application::Plugin::Redirect;
use CGI::Application::Plugin::LogDispatch;
use CGI::Application::Plugin::Session;


# Load our magic maker plugins
use Class::Inspector;
use CGI::Application::Muto::MethodAttributes;
use Data::Dumper;
use Module::Load;


# We overload the CGI::App run method to provide some extra functionality
# of our own
sub run {

    my $self = shift;

    $self->_init_controllers();
    $self->_init_controller_methods();

    #Some callbacks
    $self->add_callback('prerun', \&_fetch_controller_method);
    $self->add_callback('prerun', \&_check_protected_methods);

    return $self->SUPER::run(); #call CGI::App run method

}


sub _init_controllers{

    my $self = shift;

    # @controller_paths define the search path where we want to search for
    # plugins
    our @controller_paths = ('Muto::App::Controller');
    push @controller_paths, $self->param('controller_path') if $self->param('controller_path');

    # Using Module::Pluggable we fetch the list of all available plugins
    # and have them available by the '_contr' method in our namespace
    use Module::Pluggable search_path => \@controller_paths,
                          sub_name => '_contr';

    # We iterate through the plugin list and using Module::Load we
    # attempt to load them
    for my $Controller( $self->_contr ){
        load $Controller;
    }

    return;
}


# We are gonna provide a really cool way of making our methods work similar to
# the ones on Catalyst
# This code has been taken almost entirely from the module
# CGI::Application::Plugin::ActionDispatch by Jason Yates, [e-mail]
# so all credit goes to him on this aspect of the code
our %_attr_cache;
my %methods;
my $init_attr_handlers = 1;

sub CGI::Application::Muto::Path :ATTR {
  my ($class, $referent, $attr, $data) = @_;

  $data ||='';
  $data =~ s/\/$//;
  unless( $data =~ /^\// ) {
    $data = "/" . $data;
  }

  my $regex = qr/^$data\/?(\/.*)?$/;
  push(@{ $_attr_cache{$class}{$attr} }, [ $referent, $regex ]);
}

sub CGI::Application::Muto::Regex :ATTR {
  my ($package, $referent, $attr, $data) = @_;
  my $regex = qr/$data/;
  push(@{ $_attr_cache{$package}{$attr} }, [$referent, $regex ]);
}

sub CGI::Application::Muto::Runmode :ATTR {
  my ($package, $referent, $attr, $data) = @_;

  $data = $methods{$referent};
  my $regex = qr/^\/$data\/?$/;
  push(@{ $_attr_cache{$package}{$attr} }, [ $referent, $regex ]);
}

sub CGI::Application::Muto::Default :ATTR {
  my ($package, $referent, $attr, $data) = @_;
  $_attr_cache{$package}{$attr} = $referent;
}

sub CGI::Application::Muto::ErrorRunmode :ATTR {
  my ($package, $referent, $attr, $data) = @_;
  $_attr_cache{$package}{$attr} = $referent;
}

# We register the methods into CGI::App's run mode map
sub _init_controller_methods {

  my $self = shift;
  my $class = ref $self || $self;

  # Setup a hash table of all the methods in the class.
  $methods{$self->can($_)} = $_
    foreach @{ Class::Inspector->methods($class) || [] }; #NOTE: This will search through ISA also.

  CGI::Application::Muto::MethodAttributes::init();

  if(defined $_attr_cache{$class}{'Default'}) {
    my $runmode = $methods{$_attr_cache{$class}{'Default'}};
    $self->start_mode($runmode);
    $self->run_modes($runmode => $runmode);
  }

  if(defined $_attr_cache{$class}{'ErrorRunmode'}) {
    $self->error_mode($methods{$_attr_cache{$class}{'ErrorRunmode'}});
  }

}

# Based on the 'path_env' variable we try to identify the correct
# method to execute
sub _fetch_controller_method {

  my $self = shift;
  my $class = ref $self || $self;

  my $_TEST_PATH_ON = $self->param('path_env') || 'PATH_INFO';
  my $_PATH_PREFIX = $self->param('path_prefix') || '';

  return unless defined $ENV{$_TEST_PATH_ON};

  my $_PATH_INFO = $ENV{$_TEST_PATH_ON};

  $_PATH_INFO =~ s/\?.*$//;

  if( $_PATH_PREFIX ){
    $_PATH_INFO =~ s/^$_PATH_PREFIX//;
  }

  my $start_mode = $self->start_mode();
  ATTR: foreach my $type (qw( Runmode Regex Path )) {
    my($code, @args) = _match_type($class, $type, $_PATH_INFO);
    if($code) {
      # Make sure the runmode isn't set already and prerun_mode isn't set.
      if(! $self->prerun_mode()) {
              # Sorta of a hack here to actually get the runmode to run.
        my $runmode = $methods{$code};
        $self->run_modes($runmode => $runmode);
        $self->prerun_mode($runmode);

              # Set the action_args array.
              $self->action_args(@args);
      }

      last ATTR;
    }
  }

}

# This little function tries to match the method on the $path_info
# if several methods mathc, then it uses the one that matches
# the closest
sub _match_type {

  my($class, $type, $path_info) = @_;

  my $min;
  my(@path_args, $code);
  foreach my $attr (@{ $_attr_cache{$class}{$type} }) {
    if(my @args = ($path_info =~ $attr->[1])) {
      # We want to match the most accurate Path().  This is
      # done by counting the args, and finding the Path with
      # the fewest amount of args left over.
      if($type eq 'Path') {
        if(@args && $args[0]) {
          $args[0] =~ s/^\///;
          @path_args = split('/', $args[0]);
        }

        # Set min if not defined.
        $min = scalar(@path_args) if( not defined $min );

        # If complete match return.
        if( scalar(@path_args) == 0 ) {
          return ($attr->[0], undef);
        } elsif(scalar(@path_args) <= $min) {
          # Has fewest @path_args so far.
          $min = scalar(@path_args);
          $code = $attr->[0];
        }
      } else {
              return ($attr->[0], @args);
      }
    }
  }
  return @path_args ? ($code, @path_args) : 0;

}


sub action_args {
  my($self, @args) = @_;

  # If args are passed set them.
  if(@args) {
    $self->{__CAP_ACTION_ARGS} = [ @args ];
    return;
  }

  return undef unless defined $self->{__CAP_ACTION_ARGS};
  return wantarray ? @{$self->{__CAP_ACTION_ARGS}} : shift @{$self->{__CAP_ACTION_ARGS}};
}




# Add run mode protection
sub protect_rm{

    my $self = shift;
    my %args = @_;

    if( !$args{'Regex'} && !$args{'Path'} ){
        return;
    }
    elsif(!$args{'auth_check'}
          || !ref($args{'auth_check'})
          ||  ref($args{'auth_check'}) ne 'CODE' ){
        return;
    }
    elsif( !$args{'login_page'} ){
        return;
    }

    #Register the new protected rm
    push @{$self->{'_PROTECTED_RM'}}, \%args;

    return 1;

}


# This function checks if the path that is about to be executed
# is protected
sub _check_protected_methods{

    my $self = shift;

    my $_TEST_PATH_ON = $self->param('path_env') || 'PATH_INFO';
    my $_PATH_PREFIX = $self->param('path_prefix') || '';

    return unless defined $ENV{$_TEST_PATH_ON};

    my $_PATH_INFO = $ENV{$_TEST_PATH_ON};

    $_PATH_INFO =~ s/\?.*$//;

    if( $_PATH_PREFIX ){
        $_PATH_INFO =~ s/^$_PATH_PREFIX//;
    }

    $_PATH_INFO =~ s/^\///;

    my $_IS_PROTECTED = 0;
    my $_PRM;

    for my $prm( @{$self->{'_PROTECTED_RM'}} ){

        if( $prm->{'Path'} && $prm->{'Path'} eq $_PATH_INFO ){
            $_IS_PROTECTED = 1;
            $_PRM = $prm;
            last;
        }
        elsif( $prm->{'Regex'} && $_PATH_INFO =~ $prm->{'Regex'} ){
            $_IS_PROTECTED = 1;
            $_PRM = $prm;
            last;
        }

    }


    #we are on a protected method
    if( $_IS_PROTECTED && $_PRM ){
        if( $_PRM->{'auth_check'}->($self) ){
            return 1;
        }
        else{
            return $self->redirect($_PRM->{'login_page'});
        }
    }
    else{
        return 1;
    }

}

1;
__END__