File Coverage

lib/HTTP/Router/Route.pm
Criterion Covered Total %
statement 85 85 100.0
branch 34 42 80.9
condition 5 9 55.5
subroutine 19 19 100.0
pod 6 6 100.0
total 149 161 92.5


line stmt bran cond sub pod time code
1             package HTTP::Router::Route;
2              
3 19     19   3385 use strict;
  19         41  
  19         791  
4 19     19   104 use warnings;
  19         40  
  19         516  
5 19     19   110 use base 'Class::Accessor::Fast';
  19         34  
  19         2511  
6 19     19   55850 use URI::Template::Restrict;
  19         65038  
  19         164  
7 19     19   11838 use HTTP::Router::Match;
  19         56  
  19         138  
8 19     19   492 use Scalar::Util ();
  19         41  
  19         3900  
9              
10             __PACKAGE__->mk_accessors(qw'path params conditions');
11              
12             sub new {
13 211     211 1 1093 my ($class, %args) = @_;
14 211         2043 return bless {
15             path => '',
16             params => {},
17             conditions => {},
18             %args,
19             }, $class;
20             }
21              
22             sub parts {
23 553     553 1 1855 my $self = shift;
24 553   66     5784 $self->{parts} ||= $self->path =~ tr!/!/!;
25             }
26              
27             sub append_path {
28 15     15 1 24 my ($self, $path) = @_;
29 15 50       60 $self->{path} .= (defined $path ? $path : '');
30             }
31              
32             {
33 19     19   107 no strict 'refs';
  19         37  
  19         3186  
34             for my $name (qw'params conditions') {
35             *{"add_${name}"} = sub {
36 17     17   40 my ($self, %args) = @_;
37 17         56 while (my ($key, $value) = each %args) {
38 24         140 $self->$name->{$key} = $value;
39             }
40             };
41             }
42             }
43              
44             sub templates {
45 1282     1282 1 1837 my $self = shift;
46 1282   66     4716 $self->{templates} ||= URI::Template::Restrict->new($self->path);
47             }
48              
49             {
50 19     19   109 no strict 'refs';
  19         35  
  19         15522  
51             for my $method (qw'variables extract') {
52             *{$method} = sub {
53 1275     1275   2502 my ($self, @args) = @_;
54 1275         5293 $self->templates->$method(@args);
55             };
56             }
57             }
58              
59             sub match {
60 876     876 1 1273 my ($self, $req) = @_;
61 876 50 33     6109 return unless Scalar::Util::blessed($req) and $req->can('path');
62              
63 876         4480 my $path = $req->path;
64 876 50       1911 defined $path or return;
65              
66             # path, captures
67 876         928 my %captures;
68 876 100       1870 if ($self->variables) {
69 539         59759 my $size = $path =~ tr!/!/!;
70 539 100       3049 $size == $self->parts or return; # FIXME: ignore parts
71 270 100       1117 %captures = $self->extract($path) or return;
72 69 100       9894 $self->_is_valid_variables(\%captures) or return;
73             }
74             else {
75 337 100       11470 $path eq $self->path or return;
76             }
77              
78             # conditions
79 129 100       1081 $self->_is_valid_request($req) or return;
80              
81 88         325 my %params = %captures;
82 88         176 for my $key (keys %{ $self->params }) {
  88         370  
83 162 50       1080 next if exists $params{$key};
84 162         398 $params{$key} = $self->params->{$key};
85             }
86              
87 88         1477 return HTTP::Router::Match->new(
88             params => \%params,
89             captures => \%captures,
90             route => $self,
91             );
92             }
93              
94             sub _is_valid_variables {
95 69     69   1332 my ($self, $vars) = @_;
96              
97 69         313 for my $name (keys %$vars) {
98 84 100       335 return 0 unless $self->_validate($vars->{$name}, $self->conditions->{$name});
99             }
100              
101 65         242 return 1;
102             }
103              
104             sub _is_valid_request {
105 129     129   344 my ($self, $req) = @_;
106              
107 129         162 my $conditions = do {
108 129         329 my %vars = map { $_ => 1 } $self->variables;
  80         4629  
109 129         1860 [ grep { !$vars{$_} } keys %{ $self->conditions } ];
  107         2243  
  129         580  
110             };
111              
112 129         429 for my $name (@$conditions) {
113 100 50       373 return 0 unless my $code = $req->can($name);
114              
115 100         306 my $value = $code->($req);
116 100 50       277 if ($name eq 'method') { # HEAD equals to GET
117 100 50       268 $value = 'GET' if $value eq 'HEAD';
118             }
119              
120 100 100       288 return 0 unless $self->_validate($value, $self->conditions->{$name});
121             }
122              
123 88         353 return 1;
124             }
125              
126             sub _validate {
127 190     190   1293 my ($self, $input, $expected) = @_;
128             # arguments
129 190 50       426 return 0 unless defined $input;
130 190 100       638 return 1 unless defined $expected;
131             # validation
132 114 100       452 return $input =~ $expected if ref $expected eq 'Regexp';
133 99 100       214 return grep { $input eq $_ } @$expected if ref $expected eq 'ARRAY';
  2         9  
134 98         620 return $input eq $expected;
135             }
136              
137             sub uri_for {
138 5     5 1 9 my ($self, $args) = @_;
139              
140 5 100       7 for my $name (keys %{ $args || {} }) {
  5         26  
141 6 100       45 return unless $self->_validate($args->{$name}, $self->conditions->{$name});
142             }
143              
144 4         18 return $self->templates->process_to_string(%$args);
145             }
146              
147             1;
148              
149             =for stopwords params
150              
151             =head1 NAME
152              
153             HTTP::Router::Route - Route Representation for HTTP::Router
154              
155             =head1 SYNOPSIS
156              
157             use HTTP::Router;
158             use HTTP::Router::Route;
159              
160             my $router = HTTP::Router->new;
161              
162             my $route = HTTP::Router::Route->new(
163             path => '/',
164             conditions => { method => 'GET' },
165             params => { controller => 'Root', action => 'index' },
166             );
167              
168             $router->add_route($route);
169              
170             =head1 METHODS
171              
172             =head2 match($req)
173              
174             Returns a L object, or C
175             if route does not match a given request.
176              
177             =head2 append_path($path)
178              
179             Appends path to route.
180              
181             =head2 add_params($params)
182              
183             Adds parameters to route.
184              
185             =head2 add_conditions($conditions)
186              
187             Adds conditions to route.
188              
189             =head2 extract($path)
190              
191             Extracts variable values from $path, and returns variable hash.
192              
193             =head2 uri_for($args?)
194              
195             Returns a path which is processed with parameters.
196              
197             =head1 PROPERTIES
198              
199             =head2 path
200              
201             Path string for route.
202              
203             =head2 params
204              
205             Route specific parameters.
206              
207             =head2 conditions
208              
209             Conditions for determining route.
210              
211             =head2 templates
212              
213             L representation with route path.
214              
215             =head2 parts
216              
217             Size of splitting route path with slash.
218              
219             =head2 variables
220              
221             Variable names in route path.
222              
223             =head1 AUTHOR
224              
225             NAKAGAWA Masaki Emasaki@cpan.orgE
226              
227             =head1 LICENSE
228              
229             This library is free software; you can redistribute it and/or modify
230             it under the same terms as Perl itself.
231              
232             =head1 SEE ALSO
233              
234             L
235              
236             =cut