File Coverage

lib/Drogo/Dispatcher.pm

Criterion	Covered	Total	%
statement	81	107	75.7
branch	28	46	60.8
condition	10	18	55.5
subroutine	7	12	58.3
pod	4	5	80.0
total	130	188	69.1

package Drogo::Dispatcher;

use base qw(
    Exporter
    Drogo::Dispatcher::Attributes
);

use strict;

use Drogo::Response;
use Drogo::Request;
use Drogo::RequestResponse;

our @EXPORT = qw(dig_for_dispatch);

# keep a list of dispatched paths
my %path_cache;

=head1 NAME

Drogo::Dispatcher - Internals for Drogo dispatching

=head1 Synopsis

Automatic dispatcher built on code attributes.

=head1 Methods

=cut

sub dig_for_dispatch
{
    my ($self, %params) = @_;
    my $class        = $params{class};
    my $path         = $params{path};
    my $mapping      = $params{mapping} || {};
    my $called_path  = $path || $params{called_path}; # the complete path
    my $dispatch_url = $params{dispatch_url} || '';
    my $trailing     = $params{trailing} || [];  # unmatched trailing arguments

    # reset self
    $self = $params{self} if $params{self};

    # dereference class
    $class = ref $class ? ref $class : $class;

    # check cache (for fast dispatches)
    return $path_cache{"${class}::${called_path}"}
        if $path_cache{"${class}::${called_path}"};

    # change the class, if applicable to the mapping table
    for my $new_class (keys %$mapping)
    {
        if ($new_class eq $path or
            $path =~ /^$new_class\//)
        {
            $class = $mapping->{$new_class};
            $path  =~ s/^$new_class//;
        }
    }

    # sanitize path
    {
        # remove starting slash
        $path =~ s/^\///;

        # remove trailing slash
        $path =~ s/\/+$//;

        # remove index trailing (you can't call index directly)
        $path =~ s/(\/|^)index$//;

        # append 'index' if no path given
        $path .= 'index' unless $path;
    }

    # build list of paths
    my @paths = split('/', $path);

    # build method call
    my $call_class   = $class;
    my $method       = pop @paths;
    my $remote_class = $class;
       $remote_class = join('::', $class, join('::', @paths))
           if @paths;

    &_class_is_imported($remote_class) if $params{auto_import};

    if (UNIVERSAL::can($remote_class, 'get_dispatch_flags'))
    {
        my $methods    = $remote_class->get_dispatch_flags;
        my $used_index = 0;

        # if this is a page index, find the index sub name
        if ($method eq 'index')
        {
            ($method) = grep { $methods->{$_} eq 'index' } keys %$methods;
            $used_index = 1;
        }

        if ($methods->{$method})
        {
            # perform dispatch
            {
                no strict 'refs'; # evil
                my $subptr = join('::', $remote_class, $method);

                # store path in cache
                $path_cache{"${class}::${called_path}"} = {
                    class        => $remote_class,
                    method       => $method,
                    sub          => \&$subptr,
                    index        => $used_index,
                    dispatch_url => join('/', $dispatch_url, $path),
                };

                return $path_cache{"${class}::${called_path}"};
            }
        }
        else
        {
            # attempt to jump forward
            {
                my $jump_class = join('::', $remote_class, $method);

                &_class_is_imported($jump_class) if $params{auto_import};
                if (UNIVERSAL::can($jump_class, 'get_dispatch_flags'))
                {
                    return $jump_class->dig_for_dispatch(
                        self         => $self,
                        class        => $jump_class,
                        path         => '',
                        called_path  => $called_path,
                        dispatch_url => $path,
                    );
                }
            }

            return { error => 'bad_dispatch' };
        }
    }
    else # get_dispatch_flags is not assessable
    {
        # attempt to jump backward
        {
            my @jump_paths = @paths;
            my @post_args  = ($method);

            while (@jump_paths)
            {
                my $method     = pop @jump_paths;
                my $jump_class = join('::', $class, @jump_paths);

                &_class_is_imported($jump_class) if $params{auto_import};

                if (UNIVERSAL::can($jump_class, 'get_dispatch_flags'))
                {
                    my $dispatch_flags = $jump_class->get_dispatch_flags;

                    if ($dispatch_flags->{$method} and
                        $dispatch_flags->{$method} eq 'action_match')
                    {
                        my $subptr = join('::', $jump_class, $method);

                        return {
                            class        => $jump_class,
                            method       => $method,
                            sub          => \&$subptr,
                            index        => 0,
                            dispatch_url => $called_path,
                            post_args    => \@post_args,
                        };
                    }

                    # check every action matching regex
                    for my $m (keys %$dispatch_flags)
                    {
                        my $a = $dispatch_flags->{$m};
                        my ($act, $attr) = split('-', $a);

                        next if $act ne 'action_regex' and $act ne 'path';

                        if ($act eq 'action_regex')
                        {
                            my $post_args = join('/', $method, @post_args);
                            my @results = ( $post_args =~ /$attr/ );

                            if (@results)
                            {
                                my $subptr = join('::', $jump_class, $m);

                                return {
                                    class        => $jump_class,
                                    method       => $m,
                                    sub          => \&$subptr,
                                    index        => 0,
                                    dispatch_url => $called_path,
                                    post_args    => \@results,
                                };
                            }
                        }
                        elsif ($act eq 'path')
                        {
                            my $post_args = join('/', $method, @post_args);

                            my @results = ( $post_args =~ /^$attr$/ );

                            if (@results)
                            {
                                my $subptr = join('::', $jump_class, $m);

                                return {
                                    class        => $jump_class,
                                    method       => $m,
                                    sub          => \&$subptr,
                                    index        => 0,
                                    dispatch_url => $called_path,
                                };
                            }
                        }

                    }
                }

                unshift @post_args, $method;
            }
        }

        return { error => 'bad_dispatch' };
    }
}

# _class_is_imported(Some::Class)
#
# If a class is not imported, import it.
#

sub _class_is_imported
{
    my $class = shift;

    (my $class_file = $class) =~ s{::}{/}g;
    $class_file .= '.pm'; # Let's assume all class files end in .pm

    if (not exists $INC{$class_file})
    {
        for my $base_path (@INC)
        {
            my $full_path = join('/', $base_path, $class_file);

            if (-e $full_path)
            {
                eval qq{use $class;};
                warn "-->$@<--" if $@;
                return;
            }
        }
    }
}

=head2 server

Returns server object.

=cut

sub server { shift->r->server }

=head2 r

Returns RequestResponse object.

=cut

sub r
{
    my $self = shift;

    return Drogo::RequestResponse->new($self);
}

*dispatcher = *r;

=head2 request

Returns Request object.

=cut

sub request
{
    my $self = shift;

    return Drogo::Request->new($self);
}

*req = *request;

=head2 response

Returns Response object.

=cut

sub response
{
    my $self = shift;

    return Drogo::Response->new($self);
}

*res = *response;

=head1 AUTHORS

Bizowie

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2013 Bizowie

This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself.

=cut

1;