File Coverage

blib/lib/CGI/Application/Plugin/ActionDispatch.pm

Criterion	Covered	Total	%
statement	101	101	100.0
branch	30	34	88.2
condition	3	8	37.5
subroutine	19	19	100.0
pod	1	6	16.6
total	154	168	91.6

package CGI::Application::Plugin::ActionDispatch;

use strict;
use Data::Dumper;
use Class::Inspector;
use CGI::Application::Plugin::ActionDispatch::Attributes;
require Exporter;

our $VERSION = '0.99';
our @ISA = qw(Exporter);
our @EXPORT = qw(action_args);

our %_attr_cache;
my %methods;

sub CGI::Application::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::Regex :ATTR {
  my ($package, $referent, $attr, $data) = @_;
  my $regex = qr/$data/;
  push(@{ $_attr_cache{$package}{$attr} }, [$referent, $regex ]);
}

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

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

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

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

sub import {
  my $caller = caller;
  $caller->add_callback('init', \&_ad_init);
  $caller->add_callback('prerun', \&_ad_prerun);
  goto &Exporter::import;
}

sub _ad_init {
  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::Plugin::ActionDispatch::Attributes::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'}});
  }
}

sub _ad_prerun {
  my $self = shift;
  my $class = ref $self || $self;

  return unless defined $ENV{PATH_INFO};

  my $start_mode = $self->start_mode();
  ATTR: foreach my $type (qw( Runmode Regex Path )) {
    my($code, @args) = _match_type($class, $type, $ENV{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;
    }
  }
}

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(defined($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}};
}

1;
__END__