File Coverage

blib/lib/Router/Boom.pm
Criterion Covered Total %
statement 86 86 100.0
branch 25 26 96.1
condition 3 3 100.0
subroutine 13 13 100.0
pod 3 4 75.0
total 130 132 98.4


line stmt bran cond sub pod time code
1             package Router::Boom;
2 6     6   82296 use 5.008005;
  6         24  
  6         268  
3 6     6   34 use strict;
  6         15  
  6         200  
4 6     6   32 use warnings;
  6         19  
  6         164  
5 6     6   31 use Carp ();
  6         12  
  6         531  
6              
7             our $VERSION = "1.01";
8              
9             # Matcher stuff
10             our $LEAF_IDX;
11             our @CAPTURED;
12              
13             # Compiler stuff
14             our @LEAVES;
15             our $PAREN_CNT;
16             our @PARENS;
17              
18 6     6   32 use re 'eval';
  6         11  
  6         412  
19              
20 6     6   26299 use Router::Boom::Node;
  6         17  
  6         6267  
21              
22             sub new {
23 6     6 1 646 my $class = shift;
24 6         18 my $self = bless { }, $class;
25 6         51 $self->{root} = Router::Boom::Node->new(key => '/');
26 6         20 return $self;
27             }
28              
29             # True if : ()
30             # False if : (?:)
31             sub _is_normal_capture {
32 6     6   40 $_[0] =~ /
33             \(
34             (?!
35             \?:
36             )
37             /x
38             }
39              
40             sub add {
41 19     19 1 93 my ($self, $path, $stuff) = @_;
42 19         69 $path =~ s!\A/!!;
43              
44 19         33 delete $self->{regexp}; # clear cache
45              
46 19         30 my $p = $self->{root};
47 19         22 my @capture;
48 19         99 while ($path =~ m!\G(?:
49             \{((?:\{[0-9,]+\}|[^{}]+)+)\} | # /blog/{year:\d{4}}
50             :([A-Za-z0-9_]+) | # /blog/:year
51             (\*) | # /blog/*/*
52             ([^{:*]+) # normal string
53             )!xg) {
54              
55 33 100       646 if (defined $1) {
    100          
    100          
56 10         32 my ($name, $pattern) = split /:/, $1, 2;
57 10 100 100     59 if (defined($pattern) && _is_normal_capture($pattern)) {
58 1         210 Carp::croak("You can't include parens in your custom rule.");
59             }
60 9         16 push @capture, $name;
61 9 100       29 $pattern = $pattern ? "($pattern)" : "([^/]+)";
62 9         27 $p = $p->add_node($pattern);
63             } elsif (defined $2) {
64 5         10 push @capture, $2;
65 5         17 $p = $p->add_node("([^/]+)");
66             } elsif (defined $3) {
67 1         3 push @capture, '*';
68 1         4 $p = $p->add_node("(.+)");
69             } else {
70 17         80 $p = $p->add_node(quotemeta $4);
71             }
72             }
73 18         79 $p->leaf([\@capture, $stuff]);
74              
75 18         139 return;
76             }
77              
78             sub _build_regexp {
79 4     4   10 my ($self) = @_;
80              
81 4         10 my $trie = $self->{root};
82 4         10 local @LEAVES;
83 4         8 local $PAREN_CNT = 0;
84 4         7 local @PARENS;
85 4         16 my $re = _to_regexp($trie);
86 4         17 $self->{leaves} = [@LEAVES];
87 4         136 $self->{regexp} = qr{\A$re};
88             }
89              
90             sub match {
91 23     23 1 56 my ($self, $path) = @_;
92              
93             # "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"
94             # -- by @miyagawa
95             #
96             # see http://blog.64p.org/entry/2012/10/05/132354
97 23 100       64 $path = '/' if $path eq '';
98              
99 23 100       63 if ($path =~ $self->regexp) {
100 21         34 my ($captured, $stuff) = @{$self->{leaves}->[$Router::Boom::LEAF_IDX]};
  21         65  
101 21         33 my %captured;
102 21         53 @captured{@$captured} = @Router::Boom::CAPTURED;
103 21         165 return ($stuff, \%captured);
104             } else {
105 2         13 return ();
106             }
107             }
108              
109             sub regexp {
110 24     24 0 39 my $self = shift;
111 24 100       68 if (not exists $self->{regexp}) {
112 4         14 $self->_build_regexp();
113             }
114 24         6993 $self->{regexp};
115             }
116              
117             sub _to_regexp {
118 30     30   40 my ($node) = @_;
119              
120 30         32 my %leaves;
121              
122 30         56 local @PARENS = @PARENS;
123              
124 30         80 my $key = $node->key;
125 30 100       208 if ($key =~ /\(/) {
126 11         11 $PAREN_CNT++;
127 11         15 push @PARENS, $PAREN_CNT;
128             }
129 30         31 my @re;
130 30 100       31 if (@{$node->children}>0) {
  30         70  
131 18         99 push @re, map { _to_regexp($_) } @{$node->children};
  26         144  
  18         41  
132             }
133 30 100       145 if ($node->leaf) {
134 17         103 push @Router::Boom::LEAVES, $node->leaf;
135 17         130 push @re, sprintf '\z(?{ $Router::Boom::LEAF_IDX=%s; @Router::Boom::CAPTURED = (%s) })', @Router::Boom::LEAVES-1, join(',', map { "\$$_" } @PARENS);
  14         71  
136             }
137 30         121 my $re = $node->key;
138 30 50       1129 if (@re==0) {
    100          
139             # nop
140             } elsif (@re == 1) {
141 23         44 $re .= $re[0];
142             } else {
143 7         36 $re .= '(?:' . join('|', @re) . ')';
144             }
145 30         3083 return qr{$re};
146             }
147              
148             1;
149             __END__