File Coverage

blib/lib/Path/Dispatcher/Declarative/Builder.pm

Criterion	Covered	Total	%
statement	90	102	88.2
branch	20	32	62.5
condition	5	6	83.3
subroutine	21	25	84.0
pod	0	13	0.0
total	136	178	76.4

package Path::Dispatcher::Declarative::Builder;
use Any::Moose;

our $OUTERMOST_DISPATCHER;
our $UNDER_RULE;

has dispatcher => (
    is          => 'ro',
    isa         => 'Path::Dispatcher',
    lazy        => 1,
    default     => sub { return Path::Dispatcher->new },
);

has case_sensitive_tokens => (
    is          => 'rw',
    isa         => 'Bool',
    default     => 1,
);

has token_delimiter => (
    is          => 'rw',
    isa         => 'Str',
    default     => ' ',
);

sub next_rule () {
    die "Path::Dispatcher next rule\n";
}

sub last_rule () {
    die "Path::Dispatcher abort\n";
}

sub dispatch {
    my $self = shift;

    local $OUTERMOST_DISPATCHER = $self->dispatcher
        if !$OUTERMOST_DISPATCHER;

    $OUTERMOST_DISPATCHER->dispatch(@_);
}

sub run {
    my $self = shift;

    local $OUTERMOST_DISPATCHER = $self->dispatcher
        if !$OUTERMOST_DISPATCHER;

    $OUTERMOST_DISPATCHER->run(@_);
}

sub complete {
    my $self       = shift;
    my $dispatcher = shift;

    local $OUTERMOST_DISPATCHER = $self->dispatcher
        if !$OUTERMOST_DISPATCHER;

    $OUTERMOST_DISPATCHER->complete(@_);
}

sub rewrite {
    my $self = shift;
    my ($from, $to) = @_;
    my $rewrite = sub {
        local $OUTERMOST_DISPATCHER = $self->dispatcher
            if !$OUTERMOST_DISPATCHER;
        my $path = ref($to) eq 'CODE' ? $to->() : $to;
        $OUTERMOST_DISPATCHER->run($path, @_);
    };
    $self->_add_rule($from, $rewrite);
}

sub on {
    my $self = shift;
    $self->_add_rule(@_);
}

sub enum {
    my $self = shift;
    Path::Dispatcher::Rule::Enum->new(
        enum => [@_],
    );
}

sub then {
    my $self = shift;
    my $block = shift;
    my $rule = Path::Dispatcher::Rule::Always->new(
        block => sub {
            $block->(@_);
            next_rule;
        },
    );
    $self->_add_rule($rule);
}

sub chain {
    my $self = shift;
    my $block = shift;
    my $rule = Path::Dispatcher::Rule::Chain->new(
        block => $block,
    );
    $self->_add_rule($rule);
}

sub under {
    my $self = shift;
    my ($matcher, $rules) = @_;

    my $predicate = $self->_create_rule($matcher, prefix => 1);

    my $under = Path::Dispatcher::Rule::Under->new(
        predicate => $predicate,
    );

    $self->_add_rule($under, @_);

    do {
        local $UNDER_RULE = $under;
        $rules->($UNDER_RULE);
    };
}

sub redispatch_to {
    my $self = shift;
    my $dispatcher = shift;

    # assume it's a declarative dispatcher
    if (!ref($dispatcher)) {
        $dispatcher = $dispatcher->dispatcher;
    }

    my $redispatch = Path::Dispatcher::Rule::Dispatch->new(
        dispatcher => $dispatcher,
    );

    $self->_add_rule($redispatch);
}

sub rule_creators {
    return {
        ARRAY => sub {
            my ($self, $tokens, %args) = @_;

            Path::Dispatcher::Rule::Tokens->new(
                tokens => $tokens,
                delimiter => $self->token_delimiter,
                case_sensitive => $self->case_sensitive_tokens,
                %args,
            ),
        },
        HASH => sub {
            my ($self, $metadata_matchers, %args) = @_;

            if (keys %$metadata_matchers == 1) {
                my ($field) = keys %$metadata_matchers;
                my ($value) = values %$metadata_matchers;
                my $matcher = $self->_create_rule($value);

                return Path::Dispatcher::Rule::Metadata->new(
                    field   => $field,
                    matcher => $matcher,
                    %args,
                );
            }

            die "Doesn't support multiple metadata rules yet";
        },
        CODE => sub {
            my ($self, $matcher, %args) = @_;
            Path::Dispatcher::Rule::CodeRef->new(
                matcher => $matcher,
                %args,
            ),
        },
        Regexp => sub {
            my ($self, $regex, %args) = @_;
            Path::Dispatcher::Rule::Regex->new(
                regex => $regex,
                %args,
            ),
        },
        empty => sub {
            my ($self, $undef, %args) = @_;
            Path::Dispatcher::Rule::Empty->new(
                %args,
            ),
        },
    };
}

sub _create_rule {
    my ($self, $matcher, %args) = @_;

    my $rule_creator;

    if ($matcher eq '') {
        $rule_creator = $self->rule_creators->{empty};
    }
    elsif (!ref($matcher)) {
        $rule_creator = $self->rule_creators->{ARRAY};
        $matcher = [$matcher];
    }
    else {
        $rule_creator = $self->rule_creators->{ ref $matcher };
    }

    $rule_creator or die "I don't know how to create a rule for type $matcher";

    return $rule_creator->($self, $matcher, %args);
}

sub _add_rule {
    my $self = shift;
    my $rule;

    if (blessed($_[0]) && $_[0]->isa('Path::Dispatcher::Rule')) {
        $rule = shift;
    }
    else {
        my ($matcher, $block) = splice @_, 0, 2;

        # set $1, etc
        my $old_block = $block;
        $block = sub {
            my $match = shift;
            my @pos = @{ $match->positional_captures };

            # we don't have direct write access to $1 and friends, so we have to
            # do this little hack. the only way we can update $1 is by matching
            # against a regex (5.10 fixes that)..
            my $re  = join '', map { defined($_) ? "(\Q$_\E)" : "(wontmatch)?" } @pos;
            my $str = join '', map { defined($_) ? $_         : ""             } @pos;

            # we need to check length because Perl's annoying gotcha of the empty regex
            # actually being an alias for whatever the previously used regex was
            # (useful last decade when qr// hadn't been invented)
            # we need to do the match anyway, because we have to clear the number vars
            ($str, $re) = ("x", "x") if length($str) == 0;

            $str =~ qr{^$re$}
                or die "Unable to match '$str' against a copy of itself ($re)!";


            $old_block->(@_);
        };

        $rule = $self->_create_rule($matcher, block => $block);
    }

    # FIXME: broken since move from ::Declarative
    # XXX: caller level should be closer to $Test::Builder::Level
#    my (undef, $file, $line) = caller(1);
    my (undef, $file, $line) = caller(2);
    my $rule_name = "$file:$line";

    if (!defined(wantarray)) {
        my $parent = $UNDER_RULE || $self->dispatcher;
        $parent->add_rule($rule);
    }
    else {
        return $rule, @_;
    }
}

__PACKAGE__->meta->make_immutable;
no Any::Moose;

1;