File Coverage

blib/lib/CGI/MiniFramework.pm

Criterion	Covered	Total	%
statement	6	78	7.6
branch	0	42	0.0
condition	0	2	0.0
subroutine	2	10	20.0
pod	7	8	87.5
total	15	140	10.7

package CGI::MiniFramework;

use strict;
use warnings;

our $VERSION = '0.01';
our $MODE;
our $MODULE;
our $ERROR_MSG;

sub new {
    my($class,$self)=(shift,{@_});
    bless($self,$class);

    my ($module,$mode) = $self->get_path_info;

    $self->init($module,$mode);

    $self;
}

sub get_path_info {
    my $self = shift;

    my $path_info = $ENV{'PATH_INFO'};

    if ( ! $path_info ) {
        $path_info = '/';
    }

    $path_info = "/$path_info" if(index($path_info, '/') != 0);

    my ($module,$mode) = (split(/\//,$path_info))[1,2];

    if ( $module ) {
        ($module) = ($module =~ /^([A-Za-z][A-Za-z0-9_\-\:\']+)$/);
    }
    else {
        $mode = q{};
    }

    return ($module,$mode);
}

sub init {
    my $self   = shift;
    my $module = shift;
    my $mode   = shift;

    $self->mode($mode) if $mode;

    if ( $mode ) {
        $self->mode($mode);
    }
    elsif( $self->{'DEFAULT_MODE'} ) {
        $self->mode($self->{'DEFAULT_MODE'});
    }
    else {
        $self->mode('start');
    }

    if ( $module ) {
        $self->module($module);
    }
    elsif( $self->{'DEFAULT'} ) {
        $self->module($self->{'DEFAULT'});
    }
    else {
        $self->module(q{});
    }

    return;
}

sub run {
    my $self = shift;

    my $obj = $self->get_object;

    if ( ! $obj ) {
        die $self->error;
    }

    my $mode = $self->mode;

    my $do_mode = $obj->setup($mode);

    if ( ! $do_mode ) {
        my $class = ref($obj);
        die "There is no execution method in $class .";
    }

    $obj->pre_run if $obj->can("pre_run");

    my $output;
    eval {
        $output = $obj->$do_mode;
    };

    if ( $@ ) {
        $obj->error_mode if $obj->can("error_mode");
        die "The error occurs by your script.";
    }

    if ( ! $output ) {
        die "Output data doesn't exist.";
    }

    $obj->teardown if $obj->can("teardown");

    return $output;
}

sub get_object {
    my $self = shift;
    my $module = $self->module;

    if ( $self->{'PREFIX'} ) {
        $module = $self->{'PREFIX'}.'::'.$module;
    }

    eval "require $module"
     or $self->error($!) and return undef;

    my $obj;
    eval {
        $obj = $module->new;
    };
    if ( $@ ) {
        $self->error($@);
        return undef;
    }

    return $obj;
}

sub module {
    my $self = shift;
    if(@_) { $MODULE = shift }
    return $MODULE;
}

sub mode {
    my $self = shift;
    if(@_) { $MODE = shift }
    return $MODE;
}

sub error {
    my $self = shift;
    if(@_) { $ERROR_MSG = shift }
    return $ERROR_MSG;
}

1;
__END__