File Coverage

blib/lib/Catalyst/DispatchType/Path.pm
Criterion Covered Total %
statement 46 56 82.1
branch 15 22 68.2
condition 4 4 100.0
subroutine 8 9 88.9
pod 5 5 100.0
total 78 96 81.2


line stmt bran cond sub pod time code
1             package Catalyst::DispatchType::Path;
2              
3 48     48   770 use strict;
  48         549  
  48         755  
4 48     48   794 use base qw/Catalyst::DispatchType/;
  48         476  
  48         858  
5 48     48   855 use Text::SimpleTable;
  48         455  
  48         1172  
6 48     48   841 use URI;
  48         2690  
  48         964  
7              
8             =head1 NAME
9            
10             Catalyst::DispatchType::Path - Path 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             Debug output for Path dispatch points
23            
24             =cut
25              
26             sub list {
27 0     0 1 0     my ( $self, $c ) = @_;
28 0         0     my $paths = Text::SimpleTable->new( [ 35, 'Path' ], [ 36, 'Private' ] );
29 0         0     foreach my $path ( sort keys %{ $self->{paths} } ) {
  0         0  
30 0 0       0         my $display_path = $path eq '/' ? $path : "/$path";
31 0         0         foreach my $action ( @{ $self->{paths}->{$path} } ) {
  0         0  
32 0         0             $paths->row( $display_path, "/$action" );
33                     }
34                 }
35 0         0     $c->log->debug( "Loaded Path actions:\n" . $paths->draw . "\n" )
36 0 0       0       if ( keys %{ $self->{paths} } );
37             }
38              
39             =head2 $self->match( $c, $path )
40            
41             For each action registered to this exact path, offers the action a chance to
42             match the path (in the order in which they were registered). Succeeds on the
43             first action that matches, if any; if not, returns 0.
44            
45             =cut
46              
47             sub match {
48 2094     2094 1 28793     my ( $self, $c, $path ) = @_;
49              
50 2094   100     24548     $path ||= '/';
51              
52 2094 100       36156     foreach my $action ( @{ $self->{paths}->{$path} || [] } ) {
  2094         42489  
53 510 100       10205         next unless $action->match($c);
54 502         14147         $c->req->action($path);
55 502         9516         $c->req->match($path);
56 502         10274         $c->action($action);
57 502         20643         $c->namespace( $action->namespace );
58 502         10077         return 1;
59                 }
60              
61 1592         30599     return 0;
62             }
63              
64             =head2 $self->register( $c, $action )
65            
66             Calls register_path for every Path attribute for the given $action.
67            
68             =cut
69              
70             sub register {
71 25049     25049 1 333945     my ( $self, $c, $action ) = @_;
72              
73 25049 100       265252     my @register = @{ $action->attributes->{Path} || [] };
  25049         371530  
74              
75 25049         383120     $self->register_path( $c, $_, $action ) for @register;
  25049         347119  
76              
77 25049 100       350271     return 1 if @register;
78 20907         312930     return 0;
79             }
80              
81             =head2 $self->register_path($c, $path, $action)
82            
83             Registers an action at a given path.
84            
85             =cut
86              
87             sub register_path {
88 4727     4727 1 77748     my ( $self, $c, $path, $action ) = @_;
89 4727         58418     $path =~ s!^/!!;
90 4727 50       59706     $path = '/' unless length $path;
91 4727         95400     $path = URI->new($path)->canonical;
92              
93 4727   100     71898     unshift( @{ $self->{paths}{$path} ||= [] }, $action);
  4727         77964  
94              
95 4727         147717     return 1;
96             }
97              
98             =head2 $self->uri_for_action($action, $captures)
99            
100             get a URI part for an action; always returns undef is $captures is set
101             since Path actions don't have captures
102            
103             =cut
104              
105             sub uri_for_action {
106 28     28 1 730     my ( $self, $action, $captures ) = @_;
107              
108 28 100       354     return undef if @$captures;
109              
110 8 100       91     if (my $paths = $action->attributes->{Path}) {
111 3         32         my $path = $paths->[0];
112 3 50       32         $path = '/' unless length($path);
113 3 50       38         $path = "/${path}" unless ($path =~ m/^\//);
114 3         44         $path = URI->new($path)->canonical;
115 3         38         return $path;
116                 } else {
117 5         81         return undef;
118                 }
119             }
120              
121             =head1 AUTHOR
122            
123             Matt S Trout
124             Sebastian Riedel, C<sri@cpan.org>
125            
126             =head1 COPYRIGHT
127            
128             This program is free software, you can redistribute it and/or modify it under
129             the same terms as Perl itself.
130            
131             =cut
132              
133             1;
134