File Coverage

blib/lib/Catalyst/Controller.pm
Criterion Covered Total %
statement 164 168 97.6
branch 61 70 87.1
condition 16 25 64.0
subroutine 34 35 97.1
pod 6 6 100.0
total 281 304 92.4


line stmt bran cond sub pod time code
1             package Catalyst::Controller;
2              
3 57     57   853 use strict;
  57         558  
  57         910  
4 57     57   1201 use base qw/Catalyst::Component Catalyst::AttrContainer Class::Accessor::Fast/;
  57         608  
  57         862  
5              
6 57     57   971 use Catalyst::Exception;
  57         603  
  57         1046  
7 57     57   925 use Catalyst::Utils;
  57         618  
  57         2117  
8 57     57   903 use Class::Inspector;
  57         598  
  57         839  
9 57     57   841 use NEXT;
  57         653  
  57         4111  
10              
11             =head1 NAME
12            
13             Catalyst::Controller - Catalyst Controller base class
14            
15             =head1 SYNOPSIS
16            
17             package MyApp::Controller::Search
18             use base qw/Catalyst::Controller;
19            
20             sub foo : Local {
21             my ($self,$c,@args) = @_;
22             ...
23             } # Dispatches to /search/foo
24            
25             =head1 DESCRIPTION
26            
27             Controllers are where the actions in the Catalyst framework reside. each
28             action is represented by a function with an attribute to identify what kind
29             of action it is. See the L<Catalyst::Dispatcher> for more info about how
30             Catalyst dispatches to actions.
31            
32             =cut
33              
34             __PACKAGE__->mk_classdata($_) for qw/_dispatch_steps _action_class/;
35              
36             __PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] );
37             __PACKAGE__->_action_class('Catalyst::Action');
38              
39             __PACKAGE__->mk_accessors( qw/_application/ );
40              
41             ### _app as alias
42             *_app = *_application;
43              
44 57         889 sub _DISPATCH : Private {
45 807     807   8076     my ( $self, $c ) = @_;
46              
47 807         8462     foreach my $disp ( @{ $self->_dispatch_steps } ) {
  807         12952  
48 2415 100       97700         last unless $c->forward($disp);
49                 }
50              
51 806         35222     $c->forward('_END');
52 57     57   4450 }
  57         5376  
53              
54 57         1045 sub _BEGIN : Private {
55 807     807   8964     my ( $self, $c ) = @_;
56 807         19377     my $begin = ( $c->get_actions( 'begin', $c->namespace ) )[-1];
57 807 100       17918     return 1 unless $begin;
58 367         6511     $begin->dispatch( $c );
59 367         11964     return !@{ $c->error };
  367         8760  
60 57     57   1211 }
  57         563  
61              
62 57         901 sub _AUTO : Private {
63 807     807   11521     my ( $self, $c ) = @_;
64 807         10913     my @auto = $c->get_actions( 'auto', $c->namespace );
65 807         13310     foreach my $auto (@auto) {
66 60         1057         $auto->dispatch( $c );
67 58 100       1432         return 0 unless $c->state;
68                 }
69 801         19046     return 1;
70 57     57   973 }
  57         671  
71              
72 57         1285 sub _ACTION : Private {
73 801     801   8934     my ( $self, $c ) = @_;
74 801 50 33     11286     if ( ref $c->action
      33        
75                     && $c->action->can('execute')
76                     && $c->req->action )
77                 {
78 801         11043         $c->action->dispatch( $c );
79                 }
80 790         24196     return !@{ $c->error };
  790         20280  
81 57     57   1297 }
  57         597  
82              
83 57         2948 sub _END : Private {
84 806     806   9378     my ( $self, $c ) = @_;
85 806         12137     my $end = ( $c->get_actions( 'end', $c->namespace ) )[-1];
86 806 50       11750     return 1 unless $end;
87 806         28070     $end->dispatch( $c );
88 806         22239     return !@{ $c->error };
  806         18051  
89 57     57   3061 }
  57         539  
90              
91             sub new {
92 3401     3401 1 271108     my $self = shift;
93 3401         45280     my $app = $_[0];
94 3401         93138     my $new = $self->NEXT::new(@_);
95 3401         312906     $new->_application( $app );
96 3401         81219     return $new;
97             }
98              
99              
100             sub action_for {
101 4     4 1 45     my ( $self, $name ) = @_;
102 4 100       274     my $app = ($self->isa('Catalyst') ? $self : $self->_application);
103 4         103     return $app->dispatcher->get_action($name, $self->action_namespace);
104             }
105              
106             sub action_namespace {
107 6465     6465 1 112342     my ( $self, $c ) = @_;
108 6465 100       81817     unless ( $c ) {
109 4 100       77         $c = ($self->isa('Catalyst') ? $self : $self->_application);
110                 }
111 6465 100       82761     my $hash = (ref $self ? $self : $self->config); # hate app-is-class
112 6465 100       116778     return $hash->{namespace} if exists $hash->{namespace};
113 6237   66     134425     return Catalyst::Utils::class2prefix( ref($self) || $self,
      100        
114                     $c->config->{case_sensitive} )
115                   || '';
116             }
117              
118             sub path_prefix {
119 3917     3917 1 47765     my ( $self, $c ) = @_;
120 3917 50       55741     unless ( $c ) {
121 0 0       0         $c = ($self->isa('Catalyst') ? $self : $self->_application);
122                 }
123 3917 100       54800     my $hash = (ref $self ? $self : $self->config); # hate app-is-class
124 3917 100       54046     return $hash->{path} if exists $hash->{path};
125 3827         68592     return shift->action_namespace(@_);
126             }
127              
128              
129             sub register_actions {
130 2632     2632 1 36663     my ( $self, $c ) = @_;
131 2632   66     39551     my $class = ref $self || $self;
132 2632         81301     my $namespace = $self->action_namespace($c);
133 2632         32419     my %methods;
134 2632 50       67340     $methods{ $self->can($_) } = $_
135 2632         25898       for @{ Class::Inspector->methods($class) || [] };
  2632         27465  
136              
137             # Advanced inheritance support for plugins and the like
138 2632         71178     my @action_cache;
139                 {
140 57     57   1208         no strict 'refs';
  57         592  
  57         1167  
  2632         31862  
141 2632         53943         for my $isa ( @{"$class\::ISA"}, $class ) {
  2632         57738  
142 5501 100       135686             push @action_cache, @{ $isa->_action_cache }
  5311         88724  
143                           if $isa->can('_action_cache');
144                     }
145                 }
146              
147 2632         44637     foreach my $cache (@action_cache) {
148 41369         601392         my $code = $cache->[0];
149 41369         866224         my $method = delete $methods{$code}; # avoid dupe registers
150 41369 100       635889         next unless $method;
151 25274         886166         my $attrs = $self->_parse_attrs( $c, $method, @{ $cache->[1] } );
  25274         477383  
152 25274 100 100     464195         if ( $attrs->{Private} && ( keys %$attrs > 1 ) ) {
153 0         0             $c->log->debug( 'Bad action definition "'
154 225 50       9773                   . join( ' ', @{ $cache->[1] } )
155                               . qq/" for "$class->$method"/ )
156                           if $c->debug;
157 225         4712             next;
158                     }
159 25049 100       405055         my $reverse = $namespace ? "$namespace/$method" : $method;
160 25049         435865         my $action = $self->create_action(
161                         name => $method,
162                         code => $code,
163                         reverse => $reverse,
164                         namespace => $namespace,
165                         class => $class,
166                         attributes => $attrs,
167                     );
168              
169 25049         627037         $c->dispatcher->register( $c, $action );
170                 }
171             }
172              
173             sub create_action {
174 25049     25049 1 360911     my $self = shift;
175 25049         606133     my %args = @_;
176              
177 25049 100       518847     my $class = (exists $args{attributes}{ActionClass}
178                                 ? $args{attributes}{ActionClass}[0]
179                                 : $self->_action_class);
180              
181 25049 100       485532     unless ( Class::Inspector->loaded($class) ) {
182 180         2470         require Class::Inspector->filename($class);
183                 }
184                 
185 25049         435292     return $class->new( \%args );
186             }
187              
188             sub _parse_attrs {
189 25274     25274   401839     my ( $self, $c, $name, @attrs ) = @_;
190              
191 25274         296822     my %raw_attributes;
192              
193 25274         308989     foreach my $attr (@attrs) {
194              
195             # Parse out :Foo(bar) into Foo => bar etc (and arrayify)
196              
197 32748 50       1014872         if ( my ( $key, $value ) = ( $attr =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ ) )
198                     {
199              
200 32748 100       484284             if ( defined $value ) {
201 10446 100       255276                 ( $value =~ s/^'(.*)'$/$1/ ) || ( $value =~ s/^"(.*)"/$1/ );
202                         }
203 32748         382122             push( @{ $raw_attributes{$key} }, $value );
  32748         1827199  
204                     }
205                 }
206              
207 25274 100       460171     my $hash = (ref $self ? $self : $self->config); # hate app-is-class
208              
209 25274 100 66     500635     if (exists $hash->{actions} || exists $hash->{action}) {
210 540   33     7834       my $a = $hash->{actions} || $hash->{action};
211 0         0       %raw_attributes = ((exists $a->{'*'} ? %{$a->{'*'}} : ()),
  90         1874  
212                                      %raw_attributes,
213 540 50       28118                          (exists $a->{$name} ? %{$a->{$name}} : ()));
    100          
214                 }
215              
216 25274         372448     my %final_attributes;
217              
218 25274         392451     foreach my $key (keys %raw_attributes) {
219              
220 32748         424840         my $raw = $raw_attributes{$key};
221              
222 32748 100       553824         foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) {
223              
224 32793         459623             my $meth = "_parse_${key}_attr";
225 32793 100       1035132             if ( $self->can($meth) ) {
226 5087         99576                 ( $key, $value ) = $self->$meth( $c, $name, $value );
227                         }
228 32793         499555             push( @{ $final_attributes{$key} }, $value );
  32793         718959  
229                     }
230                 }
231              
232 25274         501725     return \%final_attributes;
233             }
234              
235             sub _parse_Global_attr {
236 405     405   5790     my ( $self, $c, $name, $value ) = @_;
237 405         8823     return $self->_parse_Path_attr( $c, $name, "/$name" );
238             }
239              
240 90     90   1180 sub _parse_Absolute_attr { shift->_parse_Global_attr(@_); }
241              
242             sub _parse_Local_attr {
243 3152     3152   49617     my ( $self, $c, $name, $value ) = @_;
244 3152         43568     return $self->_parse_Path_attr( $c, $name, $name );
245             }
246              
247 990     990   14524 sub _parse_Relative_attr { shift->_parse_Local_attr(@_); }
248              
249             sub _parse_Path_attr {
250 4457     4457   61449     my ( $self, $c, $name, $value ) = @_;
251 4457   100     68445     $value ||= '';
252 4457 100       75975     if ( $value =~ m!^/! ) {
    100          
253 765         12705         return ( 'Path', $value );
254                 }
255                 elsif ( length $value ) {
256 3512         55133         return ( 'Path', join( '/', $self->path_prefix($c), $value ) );
257                 }
258                 else {
259 180         4544         return ( 'Path', $self->path_prefix($c) );
260                 }
261             }
262              
263             sub _parse_Regex_attr {
264 225     225   2743     my ( $self, $c, $name, $value ) = @_;
265 225         3509     return ( 'Regex', $value );
266             }
267              
268 0     0   0 sub _parse_Regexp_attr { shift->_parse_Regex_attr(@_); }
269              
270             sub _parse_LocalRegex_attr {
271 225     225   3710     my ( $self, $c, $name, $value ) = @_;
272 225 100       4632     unless ( $value =~ s/^\^// ) { $value = "(?:.*?)$value"; }
  180         2062  
273 225         2951     return ( 'Regex', '^' . $self->path_prefix($c) . "/${value}" );
274             }
275              
276 45     45   706 sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); }
277              
278             sub _parse_ActionClass_attr {
279 135     135   1894     my ( $self, $c, $name, $value ) = @_;
280 135 100       2355     unless ( $value =~ s/^\+// ) {
281 90         1657       $value = join('::', $self->_action_class, $value );
282