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                 }
283 135         2347     return ( 'ActionClass', $value );
284             }
285              
286             sub _parse_MyAction_attr {
287 45     45   596     my ( $self, $c, $name, $value ) = @_;
288              
289 45         670     my $appclass = Catalyst::Utils::class2appclass($self);
290 45         1269     $value = "${appclass}::Action::${value}";
291              
292 45         1565     return ( 'ActionClass', $value );
293             }
294              
295             1;
296              
297             __END__
298            
299             =head1 CONFIGURATION
300            
301             As any other L<Catalyst::Component>, controllers have a config
302             hash, accessable through $self->config from the controller actions.
303             Some settings are in use by the Catalyst framework:
304            
305             =head2 namespace
306            
307             This spesifies the internal namespace the controller should be bound to. By default
308             the controller is bound to the uri version of the controller name. For instance
309             controller 'MyApp::Controller::Foo::Bar' will be bound to 'foo/bar'. The default Root
310             controller is an example of setting namespace to ''.
311            
312             =head2 prefix
313            
314             Sets 'path_prefix', as described below.
315            
316             =head1 METHODS
317            
318             =head2 $class->new($app, @args)
319            
320             Proxies through to NEXT::new and stashes the application instance as
321             $self->_application.
322            
323             =head2 $self->action_for('name')
324            
325             Returns the Catalyst::Action object (if any) for a given method name in
326             this component.
327            
328             =head2 $self->register_actions($c)
329            
330             Finds all applicable actions for this component, creates Catalyst::Action
331             objects (using $self->create_action) for them and registers them with
332             $c->dispatcher.
333            
334             =head2 $self->action_namespace($c)
335            
336             Returns the private namespace for actions in this component. Defaults to a value
337             from the controller name (for e.g. MyApp::Controller::Foo::Bar becomes
338             "foo/bar") or can be overriden from the "namespace" config key.
339            
340            
341             =head2 $self->path_prefix($c)
342            
343             Returns the default path prefix for :Local, :LocalRegex and relative :Path
344             actions in this component. Defaults to the action_namespace or can be
345             overriden from the "path" config key.
346            
347             =head2 $self->create_action(%args)
348            
349             Called with a hash of data to be use for construction of a new Catalyst::Action
350             (or appropriate sub/alternative class) object.
351            
352             Primarily designed for the use of register_actions.
353            
354             =head2 $self->_application
355            
356             =head2 $self->_app
357            
358             Returns the application instance stored by C<new()>
359            
360             =head1 AUTHOR
361            
362             Sebastian Riedel, C<sri@oook.de>
363             Marcus Ramberg C<mramberg@cpan.org>
364            
365             =head1 COPYRIGHT
366            
367             This program is free software, you can redistribute it and/or modify it under
368             the same terms as Perl itself.
369            
370             =cut
371