File Coverage

blib/lib/Router/Boom.pm

Criterion	Covered	Total	%
statement	85	85	100.0
branch	25	26	96.1
condition	3	3	100.0
subroutine	13	13	100.0
pod	3	4	75.0
total	129	131	98.4

package Router::Boom;
use 5.008005;
use strict;
use warnings;
use Carp ();

our $VERSION = "1.03";

# Matcher stuff
our $LEAF_IDX;
our @CAPTURED;

# Compiler stuff
our @LEAVES;
our $PAREN_CNT;
our @PARENS;

use re 'eval';

use Router::Boom::Node;

sub new {
    my $class = shift;
    my $self = bless { }, $class;
    $self->{root} = Router::Boom::Node->new(key => '/');
    return $self;
}

# True if : ()
# False if : (?:)
sub _is_normal_capture {
    $_[0] =~ /
        \(
            (?!
                \?:
            )
    /x
}

sub add {
    my ($self, $path, $stuff) = @_;
    $path =~ s!\A/!!;

    delete $self->{regexp}; # clear cache

    my $p = $self->{root};
    my @capture;
    while ($path =~ m!\G(?:
            \{((?:\{[0-9,]+\}|[^{}]+)+)\} | # /blog/{year:\d{4}}
            :([A-Za-z0-9_]+)              | # /blog/:year
            (\*)                          | # /blog/*/*
            ([^{:*]+)                       # normal string
        )!xg) {

        if (defined $1) {
            my ($name, $pattern) = split /:/, $1, 2;
            if (defined($pattern) && _is_normal_capture($pattern)) {
                Carp::croak("You can't include parens in your custom rule.");
            }
            push @capture, $name;
            $pattern = $pattern ? "($pattern)" : "([^/]+)";
            $p = $p->add_node($pattern);
        } elsif (defined $2) {
            push @capture, $2;
            $p = $p->add_node("([^/]+)");
        } elsif (defined $3) {
            push @capture, '*';
            $p = $p->add_node("(.+)");
        } else {
            $p = $p->add_node(quotemeta $4);
        }
    }
    $p->leaf([\@capture, $stuff]);

    return;
}

sub _build_regexp {
    my ($self) = @_;

    my $trie = $self->{root};
    local @LEAVES;
    local $PAREN_CNT = 0;
    local @PARENS;
    my $re = _to_regexp($trie);
    $self->{leaves} = [@LEAVES];
    $self->{regexp} = qr{\A$re};
}

sub match {
    my ($self, $path) = @_;

    # "I think there was a discussion about that a while ago and it is up to apps to deal with empty PATH_INFO as root / iirc"
    # -- by @miyagawa
    #
    # see http://blog.64p.org/entry/2012/10/05/132354
    $path = '/' if $path eq '';

    if ($path =~ $self->regexp) {
        my ($captured, $stuff) = @{$self->{leaves}->[$Router::Boom::LEAF_IDX]};
        my %captured;
        @captured{@$captured} = @Router::Boom::CAPTURED;
        return ($stuff, \%captured);
    } else {
        return ();
    }
}

sub regexp {
    my $self = shift;
    if (not exists $self->{regexp}) {
        $self->_build_regexp();
    }
    $self->{regexp};
}

sub _to_regexp {
    my ($node) = @_;

    my %leaves;

    local @PARENS = @PARENS;

    my $key = $node->key;
    if ($key =~ /\(/) {
        $PAREN_CNT++;
        push @PARENS, $PAREN_CNT;
    }
    my @re;
    if (@{$node->children}>0) {
        push @re, map { _to_regexp($_) } @{$node->children};
    }
    if ($node->leaf) {
        push @Router::Boom::LEAVES, $node->leaf;
        push @re, sprintf '\z(?{ $Router::Boom::LEAF_IDX=%s; @Router::Boom::CAPTURED = (%s) })', @Router::Boom::LEAVES-1, join(',', map { "\$$_" } @PARENS);
    }
    my $re = $node->key;
    if (@re==0) {
        # nop
    } elsif (@re == 1) {
        $re .= $re[0];
    } else {
        $re .= '(?:' . join('|', @re) . ')';
    }
    return qr{$re};
}

1;
__END__