File Coverage

blib/lib/Path/Dispatcher/Declarative.pm

Criterion	Covered	Total	%
statement	62	66	93.9
branch	7	12	58.3
condition			n/a
subroutine	22	26	84.6
pod	0	2	0.0
total	91	106	85.8

package Path::Dispatcher::Declarative;
use strict;
use warnings;
use 5.008001;

our $VERSION = '0.03';

use Path::Dispatcher;
use Path::Dispatcher::Declarative::Builder;
use Sub::Exporter;

use constant dispatcher_class => 'Path::Dispatcher';
use constant builder_class => 'Path::Dispatcher::Declarative::Builder';

our $CALLER; # Sub::Exporter doesn't make this available

my $exporter = Sub::Exporter::build_exporter({
    into_level => 1,
    groups => {
        default => \&build_sugar,
    },
});

sub import {
    my $self = shift;
    my $pkg  = caller;

    my @args = grep { !/^-base$/i } @_;

    # just loading the class..
    return if @args == @_;

    do {
        no strict 'refs';
        push @{ $pkg . '::ISA' }, $self;
    };

    local $CALLER = $pkg;

    $exporter->($self, @args);
}

sub build_sugar {
    my ($class, $group, $arg) = @_;

    my $into = $CALLER;

    $class->populate_defaults($arg);

    my $dispatcher = $class->dispatcher_class->new(name => $into);

    my $builder = $class->builder_class->new(
        dispatcher => $dispatcher,
        %$arg,
    );

    return {
        dispatcher    => sub { $builder->dispatcher },
        rewrite       => sub { $builder->rewrite(@_) },
        on            => sub { $builder->on(@_) },
        under         => sub { $builder->under(@_) },
        redispatch_to => sub { $builder->redispatch_to(@_) },
        enum          => sub { $builder->enum(@_) },
        next_rule     => sub { $builder->next_rule(@_) },
        last_rule     => sub { $builder->last_rule(@_) },
        complete      => sub { $builder->complete(@_) },

        then  => sub (&) { $builder->then(@_) },
        chain => sub (&) { $builder->chain(@_) },

        # NOTE on shift if $into: if caller is $into, then this function is
        # being used as sugar otherwise, it's probably a method call, so
        # discard the invocant
        dispatch => sub { shift if caller ne $into; $builder->dispatch(@_) },
        run      => sub { shift if caller ne $into; $builder->run(@_) },
    };
}

sub populate_defaults {
    my $class = shift;
    my $arg  = shift;

    for my $option ('token_delimiter', 'case_sensitive_tokens') {
        next if exists $arg->{$option};
        next unless $class->can($option);

        my $default = $class->$option;
        next unless defined $default; # use the builder's default

        $arg->{$option} = $class->$option;
    }
}


1;

__END__