File Coverage

blib/lib/Cot.pm

Criterion	Covered	Total	%
statement	67	195	34.3
branch	4	36	11.1
condition	0	14	0.0
subroutine	20	45	44.4
pod	8	10	80.0
total	99	300	33.0

package Cot;

use strict;
use warnings;
use 5.008005;
our $VERSION = "0.11";
$VERSION = eval $VERSION;
use File::Spec;
use Plack::Request;
use Plack::Runner;
use Plack::App::File;
use DirHandle;
use Carp;
use vars qw($AUTOLOAD %POOL);

sub import {
    my $class = shift;
    my $pkg   = caller(0);
    strict->import;
    warnings->import;
    {
        no strict 'refs';
        push @{"$pkg\::ISA"}, $class;
    }
    for my $func (qw/run get post put patch delete options any static indexes plugin/) {
        no strict 'refs';
        *{"$pkg\::$func"} = \&{"_export_$func"};
    }
}

sub _register_plugin {
    my ( $class, $plugin_klass ) = @_;
    $plugin_klass->new->init( $class->_app );
}

sub _root {
    $ENV{COT_ROOT} || '.';
}

sub _app {
    my $class = shift;
    $POOL{ $class->_root } || $class->new;
}

sub new {
    my $class = shift;
    my $self  = bless {
        controller => {},
        plugins    => [],
    }, $class;
    $POOL{ $class->_root } = $self;
}

# get '/' => sub { my $c = shift; }
sub _method {
    my ( $class, $path, $sub, @methods ) = @_;
    foreach (@methods) {
        $class->_app->{controller}->{$_} ||= {};
        $class->_app->{controller}->{$_}->{$path} = $sub;
    }
}

sub _export_plugin {
    my @plugins = @_;
    my $class   = caller(0);
    foreach (@_) {
        my $klass = "Cot::Plugin::$_";
        eval "require $klass" or croak "Plugin[$_] is not installed.";
        $klass->_regist($class);
    }
}

sub _export_get {
    my ( $path, $sub ) = @_;
    my $class = caller(0);
    $class->_method( $path, $sub, 'get' );
}

sub _export_post {
    my ( $path, $sub ) = @_;
    my $class = caller(0);
    $class->_method( $path, $sub, 'post' );
}

sub _export_put {
    my ( $path, $sub ) = @_;
    my $class = caller(0);
    $class->_method( $path, $sub, 'put' );
}

sub _export_delete {
    my ( $path, $sub ) = @_;
    my $class = caller(0);
    $class->_method( $path, $sub, 'delete' );
}

sub _export_patch {
    my ( $path, $sub ) = @_;
    my $class = caller(0);
    $class->_method( $path, $sub, 'patch' );
}

sub _export_options {
    my ( $path, $sub ) = @_;
    my $class = caller(0);
    $class->_method( $path, $sub, 'options' );
}

sub _export_any {
    my ( $path, $sub ) = @_;
    my $class = caller(0);
    $class->_method( $path, $sub, 'get', 'post', 'put', 'patch', 'options',
        'delete' );
}

sub _export_static {
    my ($path)     = @_;
    my $class      = caller(0);
    my $controller = $class->_app->{controller};
    $controller->{get} ||= {};
    $controller->{get}->{$path} = \&_static;
}

sub _export_indexes {
    my ($path)     = @_;
    my $class      = caller(0);
    my $controller = $class->_app->{controller};
    $controller->{get} ||= {};
    $controller->{get}->{$path} = \&_indexes;
}
sub _indexes {
    my $self      = shift;
    my $path_info = $self->env->{PATH_INFO};
    my $path =
      File::Spec->catfile( $ENV{DOCUMENT_ROOT} || 'public', $path_info );
    if ( !-e $path ) {
        $self->notfound_response;
    }
    elsif ( -d $path ) {
        if ( $path_info =~ /.*\/$/ ) {
	  my $body = '';
	  my $dh = DirHandle->new($path);
	  while (defined($_ = $dh->read)) { $body .= sprintf('%s', $_,$_); }
	  $body .= '';
	  $self->res->status(200);
	  $self->res->headers({'Content-Type' => 'text/html', charset => 'utf-8'});
	  $self->res->body($body);
	  return;
        }
        else {
            $self->redirect_response( $path_info . '/' );
        }
    }
    else {
        my $file = Plack::App::File->new( file => $path )->call( $self->env );
        $self->res->status( $file->[0] );
        $self->res->headers( $file->[1] );
        $self->res->body( $file->[2] );
    }

}
sub _static {
    my $self      = shift;
    my $path_info = $self->env->{PATH_INFO};
    my $path =
      File::Spec->catfile( $ENV{DOCUMENT_ROOT} || 'public', $path_info );
    if ( !-e $path ) {
        $self->notfound_response;
    }
    elsif ( -d $path ) {
        if ( $path_info =~ /.*\/$/ ) {
            my @di = split( /:/, $ENV{COT_DIRECTORYINDEX} || '' );
            foreach my $di (@di) {
                my $index = File::Spec->catfile( $path, $di );
                if ( -f $index ) {
                    my $file =
                      Plack::App::File->new( file => $index )
                      ->call( $self->env );
                    $self->res->status( $file->[0] );
                    $self->res->headers( $file->[1] );
                    $self->res->body( $file->[2] );
                    return;
                }
            }
            $self->forbidden_response;
        }
        else {
            $self->redirect_response( $path_info . '/' );
        }
    }
    else {
        my $file = Plack::App::File->new( file => $path )->call( $self->env );
        $self->res->status( $file->[0] );
        $self->res->headers( $file->[1] );
        $self->res->body( $file->[2] );
    }

}

sub app {
    my ( $class, $env ) = @_;
    my $self      = $class->_app;
    my @path_info = ();
    my $req       = Plack::Request->new($env);
    my $method    = lc( $req->method );
    my $path      = $req->uri->path;
    $path =~ s/$env->{SCRIPT_NAME}// if $env->{SCRIPT_NAME};
    my @path = File::Spec->splitdir($path);
    my $controllers = $self->{controller}->{$method} || {};
    my $controller;

    for ( ; ; ) {
        my $u = File::Spec->catdir(@path);
        $controller = $controllers->{$u} and last;
        last unless scalar(@path);
        unshift @path_info, pop(@path);
    }
    $self->{req}       = $req;
    $self->{env}       = $env;
    $self->{res}       = $req->new_response;
    $self->{path}      = $path;
    $self->{path_info} = \@path_info;
    $controller ? &{ \&$controller }($self) : $self->forbidden_response;
    $self->res->finalize;
}
sub req       { shift->{req}; }
sub res       { shift->{res}; }
sub env       { shift->{env}; }
sub path      { shift->{path}; }
sub path_info { shift->{path_info}; }

sub forbidden_response {
    my $self = shift;
    $self->res->status(403);
    $self->res->body('forbidden');
}

sub notfound_response {
    my $self = shift;
    $self->res->status(404);
    $self->res->body('not found');
}

sub redirect_response {
    my ( $self, $url ) = @_;
    $self->res->redirect($url);
}

sub AUTOLOAD {
    my $self   = shift;
    my $caller = caller(0);
    ( my $method = $AUTOLOAD ) =~ s/.*:://;
    croak(" App can be extended only by Plugins [ !$caller->$method ] ")
      unless ( $caller->isa('Cot::Plugin') );
    no strict 'refs';
    *$method = sub {
        my $self = shift;
        $self->{$method} = $_[0] if ( $_[0] );
        return $self->{$method};
    };
    $self->$method(@_);
}

sub DESTROY { }

sub _export_run {
    my @argv   = @_;
    my $class  = caller(0);
    my $runner = Plack::Runner->new;
    if ( scalar @argv ) {
        @argv = split( /\s+/, $argv[0] ) if ( scalar @argv == 1 );
        $runner->parse_options(@argv);
    }
    my $app = sub { $class->app(shift); };
    $runner->run($app);
}

1;
__END__