File Coverage

blib/lib/Catalyst/DispatchType/Regex.pm
Criterion Covered Total %
statement 52 60 86.7
branch 17 20 85.0
condition n/a
subroutine 8 9 88.9
pod 5 5 100.0
total 82 94 87.2


line stmt bran cond sub pod time code
1             package Catalyst::DispatchType::Regex;
2              
3 48     48   680 use strict;
  48         451  
  48         683  
4 48     48   812 use base qw/Catalyst::DispatchType::Path/;
  48         514  
  48         790  
5 48     48   865 use Text::SimpleTable;
  48         486  
  48         754  
6 48     48   2943 use Text::Balanced ();
  48         559  
  48         653  
7              
8             =head1 NAME
9            
10             Catalyst::DispatchType::Regex - Regex DispatchType
11            
12             =head1 SYNOPSIS
13            
14             See L<Catalyst>.
15            
16             =head1 DESCRIPTION
17            
18             =head1 METHODS
19            
20             =head2 $self->list($c)
21            
22             Output a table of all regex actions, and their private equivalent.
23            
24             =cut
25              
26             sub list {
27 0     0 1 0     my ( $self, $c ) = @_;
28 0         0     my $re = Text::SimpleTable->new( [ 35, 'Regex' ], [ 36, 'Private' ] );
29 0         0     for my $regex ( @{ $self->{compiled} } ) {
  0         0  
30 0         0         my $action = $regex->{action};
31 0         0         $re->row( $regex->{path}, "/$action" );
32                 }
33 0         0     $c->log->debug( "Loaded Regex actions:\n" . $re->draw . "\n" )
34 0 0       0       if ( @{ $self->{compiled} } );
35             }
36              
37             =head2 $self->match( $c, $path )
38            
39             Checks path against every compiled regex, and offers the action for any regex
40             which matches a chance to match the request. If it succeeds, sets action,
41             match and captures on $c->req and returns 1. If not, returns 0 without
42             altering $c.
43            
44             =cut
45              
46             sub match {
47 797     797 1 9209     my ( $self, $c, $path ) = @_;
48              
49 797 100       23284     return if $self->SUPER::match( $c, $path );
50              
51             # Check path against plain text first
52              
53 795 100       22984     foreach my $compiled ( @{ $self->{compiled} || [] } ) {
  795         10835  
54 7856 100       126964         if ( my @captures = ( $path =~ $compiled->{re} ) ) {
55 4 50       64             next unless $compiled->{action}->match($c);
56 4         215             $c->req->action( $compiled->{path} );
57 4         142             $c->req->match($path);
58 4         47             $c->req->captures( \@captures );
59 4         142             $c->action( $compiled->{action} );
60 4         120             $c->namespace( $compiled->{action}->namespace );
61 4         62             return 1;
62                     }
63                 }
64              
65 791         54311     return 0;
66             }
67              
68             =head2 $self->register( $c, $action )
69            
70             Registers one or more regex actions for an action object.
71             Also registers them as literal paths.
72            
73             Returns 1 if any regexps were registered.
74            
75             =cut
76              
77             sub register {
78 25049     25049 1 374218     my ( $self, $c, $action ) = @_;
79 25049         371787     my $attrs = $action->attributes;
80 25049 100       336371     my @register = @{ $attrs->{'Regex'} || [] };
  25049         491525  
81              
82 25049         370376     foreach my $r (@register) {
83 450         6224         $self->register_path( $c, $r, $action );
84 450         9690         $self->register_regex( $c, $r, $action );
85                 }
86              
87 25049 100       331289     return 1 if @register;
88 24599         404904     return 0;
89             }
90              
91             =head2 $self->register_regex($c, $re, $action)
92            
93             Register an individual regex on the action. Usually called from the
94             register method.
95            
96             =cut
97              
98             sub register_regex {
99 450     450 1 5305     my ( $self, $c, $re, $action ) = @_;
100 450         29501     push(
101 450         6177         @{ $self->{compiled} }, # and compiled regex for us
102                     {
103                         re => qr#$re#,
104                         action => $action,
105                         path => $re,
106                     }
107                 );
108             }
109              
110             =head2 $self->uri_for_action($action, $captures)
111            
112             returns a URI for this action if it can find a regex attributes that contains
113             the correct number of () captures. Note that this may function incorrectly
114             in the case of nested captures - if your regex does (...(..))..(..) you'll
115             need to pass the first and third captures only.
116            
117             =cut
118              
119             sub uri_for_action {
120 25     25 1 252     my ( $self, $action, $captures ) = @_;
121              
122 25 100       300     if (my $regexes = $action->attributes->{Regex}) {
123 4         42         REGEX: foreach my $orig (@$regexes) {
124 4         38             my $re = "$orig";
125 4         44             $re =~ s/^\^//;
126 4         38             $re =~ s/\$$//;
127 4         38             my $final = '/';
128 4         43             my @captures = @$captures;
129 4         61             while (my ($front, $rest) = split(/\(/, $re, 2)) {
130 7         167                 ($rest, $re) =
131                                 Text::Balanced::extract_bracketed("(${rest}", '(');
132 7 100       78                 next REGEX unless @captures;
133 6         87                 $final .= $front.shift(@captures);
134                         }
135 3 100       34             next REGEX if @captures;
136 2         28             return $final;
137                      }
138                 }
139 23         908     return undef;
140             }
141              
142             =head1 AUTHOR
143            
144             Matt S Trout
145             Sebastian Riedel, C<sri@cpan.org>
146            
147             =head1 COPYRIGHT
148            
149             This program is free software, you can redistribute it and/or modify it under
150             the same terms as Perl itself.
151            
152             =cut
153              
154             1;
155