File Coverage

blib/lib/YATT/Lite/WebMVC0/SubRoutes.pm
Criterion Covered Total %
statement 56 62 90.3
branch 19 22 86.3
condition 4 6 66.6
subroutine 10 11 90.9
pod 0 6 0.0
total 89 107 83.1


line stmt bran cond sub pod time code
1             package YATT::Lite::WebMVC0::SubRoutes;
2 3     3   8254 use strict;
  3         8  
  3         111  
3 3     3   16 use warnings qw(FATAL all NONFATAL misc);
  3         6  
  3         146  
4 3     3   17 use Carp;
  3         7  
  3         298  
5              
6 3         41 use YATT::Lite::Types ([Route =>
7             -fields => [qw/pattern_re
8             cf_name
9 3     3   559 cf_pattern cf_item cf_params/]]);
  3         7  
10 3     3   562 use YATT::Lite::RegexpNames;
  3         7  
  3         2881  
11              
12             sub new {
13 3     3 0 1120 bless [], shift;
14             }
15              
16             sub prepend {
17 0     0 0 0 my $self = shift; unshift @$self, @_; $self;
  0         0  
  0         0  
18             }
19              
20             sub append {
21 5     5 0 9 my $self = shift; push @$self, @_; $self;
  5         14  
  5         12  
22             }
23              
24             sub match {
25 16     16 0 28 my $self = shift;
26 16         33 foreach my Route $r (@$self) {
27             my ($slash, @match) = $_[0] =~ $r->{pattern_re}
28 52 100       334 or next;
29 16   66     137 return ($r->{cf_item} // $r->{cf_name}, $r->{cf_params}, \@match);
30             }
31 0         0 return;
32             }
33              
34             sub create {
35 11     11 0 35 my ($self, $spec, $item) = @_;
36 11 100       39 my ($name, $pat) = ref $spec eq 'ARRAY' ? @$spec : (undef, $spec);
37 11         62 my Route $r = $self->Route->new;
38 11         25 $r->{cf_name} = $name;
39 11         23 $r->{cf_pattern} = $pat;
40 11         19 $r->{cf_item} = $item;
41 11         32 ($r->{pattern_re}, my @params) = $self->parse_pattern($pat);
42 11         29 $r->{cf_params} = \ @params;
43 11         50 $r;
44             }
45              
46             my %re_paren = qw!( (?: ) )?!;
47              
48             sub parse_pattern {
49 28     28 0 14301 my ($self, $pat) = @_;
50              
51 28         36 my (@pat, @params);
52 28 50       113 unless ($pat =~ m!^/!g) {
53 0         0 croak "Unsupported url pattern! $pat";
54             }
55              
56 28         39 my $last = 0;
57 28         113 while ($pat =~ m!\G(?: ([^:{}()]+) # $1 other text
58             | (?<=/) \:(\w+(?:\:\w+)*) # $2 :var:type
59             | \{(\w+ # $3 {var:...}
60             (?:
61             : (?: (?:\w+(?:\:\w+)*) # :type
62             | (?: [^{}]+ # regexp(other than {})
63             | (\{ # $4 re-qualifier(nestable)
64             (?: (?> [^{}]+)
65             | (?-1)
66             )*
67             \})
68             )+
69             )
70             )?
71             )
72             \}
73             | ([()]) # $5 (optional)
74             )
75             !xg) {
76 89 100       187 if (not @pat) {
77 26         50 push @pat, "(/)"; # To make sure first slash is captured.
78             }
79 89 100 66     359 if ($1) {
    100          
    50          
80 38         90 push @pat, quotemeta($1);
81             } elsif (my $var_type = $2 // $3) {
82 39         101 my ($name, $type_or_pat) = split /:/, $var_type, 2;
83 39         77 my $var = [$name];
84 39         52 push @pat, do {
85 39 100       154 unless ($type_or_pat) {
    100          
86 32         59 q!([^/]+)!
87             } elsif (my ($type) = $type_or_pat =~ /^(\w+)$/) {
88 1 50       19 my $sub = $self->can("re_$type")
89             or croak "Unknown pattern type: $type";
90 1         2 push @$var, $type;
91 1         4 '('.$sub->($self, 1).')'; # partial pattern
92             } else {
93 6         16 "($type_or_pat)";
94             }
95             };
96 39         81 push @params, $var;
97             } elsif ($5) {
98 12         30 push @pat, $re_paren{$5};
99             } else {
100 0         0 last;
101             }
102             } continue {
103 89         377 $last = pos($pat);
104             }
105 28 100       62 push @pat, quotemeta(substr($pat, $last)) if $last < length $pat;
106 28         63 my $all = join "", @pat;
107              
108 28         727 (qr{^$all$}x, @params);
109             }
110              
111             1;