File Coverage

blib/lib/Sledge/Engine.pm

Criterion	Covered	Total	%
statement	6	6	100.0
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	8	8	100.0

package Sledge::Engine;

use strict;
use base qw(Class::Data::Inheritable);
use Scalar::Util qw(blessed);
use File::Basename ();
use Class::Inspector;
use UNIVERSAL::require;
use Module::Pluggable::Object;
use Carp ();
use String::CamelCase qw(camelize);
use Sledge::Utils;


our $VERSION = '0.04';
our $StaticExtension = '.html';

sub import {
    my $pkg = shift;

    return unless $pkg eq 'Sledge::Engine';

    my $caller = caller(0);
    no strict 'refs';
    my $engine = 'Sledge::Engine::CGI';
    if ($ENV{MOD_PERL}) {
        my($software, $version) =
            $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
        if ($version >= 1.24 && $version < 1.90) {
            $engine = 'Sledge::Engine::Apache::MP13';
            *handler = sub ($$) { shift->run(@_); };
        }
        else {
            Carp::croak("Unsupported mod_perl version: $ENV{MOD_PERL}");
        }
    }
    $engine->require;
    push @{"$caller\::ISA"}, $engine;

    $caller->mk_classdata('ActionMap' => {});
    $caller->mk_classdata('ActionMapKeys' => []);
    $caller->mk_classdata('components' => []);

}

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self;
}

sub setup {
    my $pkg = shift;

    my $pages_class = join '::', $pkg, 'Pages';
    $pages_class->use or die $@;
    my $finder = Module::Pluggable::Object->new(
        search_path => [$pages_class],
        require => 1,
    );
    $pkg->components([$finder->plugins]);
    for my $subclass(@{$pkg->components}) {
        my $methods = Class::Inspector->methods($subclass, 'public');
        for my $method(@{$methods}) {
            if ($method =~ s/^dispatch_//) {
                $pkg->register($subclass, $method);
            }
        }
    }
    $pkg->ActionMapKeys([
        sort { length($a) <=> length($b) } keys %{$pkg->ActionMap}
    ]);
}

sub register {
    my($pkg, $class, $page) = @_;
    my $prefix = Sledge::Utils::class2prefix($class);
    my $path = $prefix eq '/' ? "/$page" : "$prefix/$page";
    $path =~ s{/index$}{/};
    $pkg->ActionMap->{$path} = {
        class => $class,
        page => $page,
    };
}

sub lookup {
    my($self, $path) = @_;
    $path ||= '/';
    $path =~ s{/index$}{/};
    my $action;
    if ($action = $self->ActionMap->{$path}) {
        return $action;
    }
    elsif ($action = $self->lookup_static($path)) {
        return $action;
    }
    # XXX handle arguments.
#     my $match;
#     for my $key(@{$self->ActionMapKeys}) {
#         next unless index($path, $key) >= 0;
#         if ($path =~ m{^$key}) {
#             $match = $key;
#         }
#     }
#     return unless $match;
#     my %action = %{$self->ActionMap->{$match}};
#     if (length($path) > length($match)) {
#         my $args = $path;
#         $args =~ s{^$match/?}{};
#         $action{args} = [split '/', $args];
#     }
#     return \%action;
}

sub lookup_static {
    my($self, $path) = @_;
    my($page, $dir, $suf) =
        File::Basename::fileparse($path, $StaticExtension);
    return if index($page, '.') >= 0;
    $page ||= 'index';
    my $class;
    if ($dir eq '/') {
        my $appname = ref $self;
        for my $subclass(qw(Root Index)) {
            $class = join '::', $appname, 'Pages', $subclass;
            last if $class->require;
        }
    }
    else {
        $dir =~ s{^/}{};
        $dir =~ s{/$}{};
        $class = join '::',
            ref($self), 'Pages', map { camelize($_) } split '/', $dir;
    }
    if ((Class::Inspector->loaded($class) || $class->require) &&
            -e $class->guess_filename($page)) {
        no strict 'refs';
        *{"$class\::dispatch_$page"} = sub {}
            unless $class->can("dispatch_$page");
        my %action = (class => $class, page => $page);
        $self->ActionMap->{$path} = \%action;
        return \%action;
    }
}

sub run {
    my $self = shift;
    unless (blessed $self) {
        $self = $self->new;
    }
    $self->handle_request(@_);
}

sub handle_request {
    die "ABSTRACT METHOD!";
}

1;

__END__