1 package Catalyst::Controller;
3 #switch to BEGIN { extends qw/ ... /; } ?
5 use base qw/Catalyst::Component Catalyst::AttrContainer/;
8 use Scalar::Util qw/blessed/;
9 use Catalyst::Exception;
18 predicate => 'has_path_prefix',
21 has action_namespace =>
25 init_arg => 'namespace',
26 predicate => 'has_action_namespace',
36 # isa => 'ClassName|Catalyst' ?
37 has _application => (is => 'rw');
38 sub _app{ shift->_application(@_) }
41 my ($self, $args) = @_;
42 my $action = delete $args->{action} || {};
43 my $actions = delete $args->{actions} || {};
44 my $attr_value = $self->merge_config_hashes($actions, $action);
45 $self->actions($attr_value);
50 Catalyst::Controller - Catalyst Controller base class
54 package MyApp::Controller::Search
55 use base qw/Catalyst::Controller/;
58 my ($self,$c,@args) = @_;
60 } # Dispatches to /search/foo
64 Controllers are where the actions in the Catalyst framework
65 reside. Each action is represented by a function with an attribute to
66 identify what kind of action it is. See the L<Catalyst::Dispatcher>
67 for more info about how Catalyst dispatches to actions.
71 #I think both of these could be attributes. doesn't really seem like they need
72 #to ble class data. i think that attributes +default would work just fine
73 __PACKAGE__->mk_classdata($_) for qw/_dispatch_steps _action_class/;
75 __PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] );
76 __PACKAGE__->_action_class('Catalyst::Action');
79 sub _DISPATCH : Private {
80 my ( $self, $c ) = @_;
82 foreach my $disp ( @{ $self->_dispatch_steps } ) {
83 last unless $c->forward($disp);
89 sub _BEGIN : Private {
90 my ( $self, $c ) = @_;
91 my $begin = ( $c->get_actions( 'begin', $c->namespace ) )[-1];
92 return 1 unless $begin;
93 $begin->dispatch( $c );
94 return !@{ $c->error };
98 my ( $self, $c ) = @_;
99 my @auto = $c->get_actions( 'auto', $c->namespace );
100 foreach my $auto (@auto) {
101 $auto->dispatch( $c );
102 return 0 unless $c->state;
107 sub _ACTION : Private {
108 my ( $self, $c ) = @_;
110 && $c->action->can('execute')
113 $c->action->dispatch( $c );
115 return !@{ $c->error };
119 my ( $self, $c ) = @_;
120 my $end = ( $c->get_actions( 'end', $c->namespace ) )[-1];
121 return 1 unless $end;
122 $end->dispatch( $c );
123 return !@{ $c->error };
129 my $new = $self->next::method(@_);
130 $new->_application( $app );
135 my ( $self, $name ) = @_;
136 my $app = ($self->isa('Catalyst') ? $self : $self->_application);
137 return $app->dispatcher->get_action($name, $self->action_namespace);
140 #my opinion is that this whole sub really should be a builder method, not
141 #something that happens on every call. Anyone else disagree?? -- groditi
143 #we are wrapping the accessor, so just uyse a modifier since a normal sub would
144 #just be overridden by the generated moose method
145 around action_namespace => sub {
147 my ( $self, $c ) = @_;
150 return $self->$orig if $self->has_action_namespace;
152 # if the following won't change at runtime it should be lazy_building thing
153 return $self->config->{namespace} if exists $self->config->{namespace};
156 #the following looks like a possible target for a default setting. i am not
157 #making the below the builder because i don't know if $c will vary from
158 #call to call, which would affect case sensitivity settings -- groditi
161 $case_s = $c->config->{case_sensitive};
163 if ($self->isa('Catalyst')) {
164 $case_s = $self->config->{case_sensitive};
167 $case_s = $self->_application->config->{case_sensitive};
169 confess("Can't figure out case_sensitive setting");
174 return Catalyst::Utils::class2prefix(ref($self) || $self, $case_s) || '';
177 #Once again, this is probably better written as a builder method
178 around path_prefix => sub {
182 return $self->$orig if $self->has_path_prefix;
184 return $self->config->{path} if exists $self->config->{path};
186 return $self->action_namespace(@_);
190 sub register_actions {
191 my ( $self, $c ) = @_;
192 my $class = ref $self || $self;
193 #this is still not correct for some reason.
194 my $namespace = $self->action_namespace($c);
196 if( $self->can('meta') ){
197 my $meta = $self->meta;
198 %methods = map{ $_->{code}->body => $_->{name} }
199 grep {$_->{class} ne 'Moose::Object'} #ignore Moose::Object methods
200 $meta->compute_all_applicable_methods;
201 } else { #until we are sure there's no moose stuff left...
202 $methods{ $self->can($_) } = $_
203 for @{ Class::Inspector->methods($class) || [] };
206 # Advanced inheritance support for plugins and the like
207 #to be modified to use meta->superclasses
208 #moose todo: migrate to eliminate CDI compat
212 for my $isa ( @{"$class\::ISA"}, $class ) {
213 push @action_cache, @{ $isa->_action_cache }
214 if $isa->can('_action_cache');
218 foreach my $cache (@action_cache) {
219 my $code = $cache->[0];
220 my $method = delete $methods{$code}; # avoid dupe registers
222 my $attrs = $self->_parse_attrs( $c, $method, @{ $cache->[1] } );
223 if ( $attrs->{Private} && ( keys %$attrs > 1 ) ) {
224 $c->log->debug( 'Bad action definition "'
225 . join( ' ', @{ $cache->[1] } )
226 . qq/" for "$class->$method"/ )
230 my $reverse = $namespace ? "${namespace}/${method}" : $method;
231 my $action = $self->create_action(
235 namespace => $namespace,
237 attributes => $attrs,
240 $c->dispatcher->register( $c, $action );
248 my $class = (exists $args{attributes}{ActionClass}
249 ? $args{attributes}{ActionClass}[0]
250 : $self->_action_class);
252 Class::MOP::load_class($class);
253 return $class->new( \%args );
257 my ( $self, $c, $name, @attrs ) = @_;
261 foreach my $attr (@attrs) {
263 # Parse out :Foo(bar) into Foo => bar etc (and arrayify)
265 if ( my ( $key, $value ) = ( $attr =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ ) )
268 if ( defined $value ) {
269 ( $value =~ s/^'(.*)'$/$1/ ) || ( $value =~ s/^"(.*)"/$1/ );
271 push( @{ $raw_attributes{$key} }, $value );
275 #I know that the original behavior was to ignore action if actions was set
276 # but i actually think this may be a little more sane? we can always remove
277 # the merge behavior quite easily and go back to having actions have
278 # presedence over action by modifying the keys. i honestly think this is
279 # superior while mantaining really high degree of compat
282 $actions = $self->actions;
284 my $cfg = $self->config;
285 $actions = $self->merge_config_hashes($cfg->{actions}, $cfg->{action});
288 %raw_attributes = ((exists $actions->{'*'} ? %{$actions->{'*'}} : ()),
290 (exists $actions->{$name} ? %{$actions->{$name}} : ()));
293 my %final_attributes;
295 foreach my $key (keys %raw_attributes) {
297 my $raw = $raw_attributes{$key};
299 foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) {
301 my $meth = "_parse_${key}_attr";
302 if ( my $code = $self->can($meth) ) {
303 ( $key, $value ) = $self->$code( $c, $name, $value );
305 push( @{ $final_attributes{$key} }, $value );
309 return \%final_attributes;
312 sub _parse_Global_attr {
313 my ( $self, $c, $name, $value ) = @_;
314 return $self->_parse_Path_attr( $c, $name, "/$name" );
317 sub _parse_Absolute_attr { shift->_parse_Global_attr(@_); }
319 sub _parse_Local_attr {
320 my ( $self, $c, $name, $value ) = @_;
321 return $self->_parse_Path_attr( $c, $name, $name );
324 sub _parse_Relative_attr { shift->_parse_Local_attr(@_); }
326 sub _parse_Path_attr {
327 my ( $self, $c, $name, $value ) = @_;
329 if ( $value =~ m!^/! ) {
330 return ( 'Path', $value );
332 elsif ( length $value ) {
333 return ( 'Path', join( '/', $self->path_prefix($c), $value ) );
336 return ( 'Path', $self->path_prefix($c) );
340 sub _parse_Regex_attr {
341 my ( $self, $c, $name, $value ) = @_;
342 return ( 'Regex', $value );
345 sub _parse_Regexp_attr { shift->_parse_Regex_attr(@_); }
347 sub _parse_LocalRegex_attr {
348 my ( $self, $c, $name, $value ) = @_;
349 unless ( $value =~ s/^\^// ) { $value = "(?:.*?)$value"; }
350 return ( 'Regex', '^' . $self->path_prefix($c) . "/${value}" );
353 sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); }
355 sub _parse_ActionClass_attr {
356 my ( $self, $c, $name, $value ) = @_;
357 unless ( $value =~ s/^\+// ) {
358 $value = join('::', $self->_action_class, $value );
360 return ( 'ActionClass', $value );
363 sub _parse_MyAction_attr {
364 my ( $self, $c, $name, $value ) = @_;
366 my $appclass = Catalyst::Utils::class2appclass($self);
367 $value = "${appclass}::Action::${value}";
369 return ( 'ActionClass', $value );
380 Like any other L<Catalyst::Component>, controllers have a config hash,
381 accessible through $self->config from the controller actions. Some
382 settings are in use by the Catalyst framework:
386 This specifies the internal namespace the controller should be bound
387 to. By default the controller is bound to the URI version of the
388 controller name. For instance controller 'MyApp::Controller::Foo::Bar'
389 will be bound to 'foo/bar'. The default Root controller is an example
390 of setting namespace to '' (the null string).
394 Sets 'path_prefix', as described below.
398 =head2 $class->new($app, @args)
400 Proxies through to NEXT::new and stashes the application instance as
403 =head2 $self->action_for('name')
405 Returns the Catalyst::Action object (if any) for a given method name
408 =head2 $self->register_actions($c)
410 Finds all applicable actions for this component, creates
411 Catalyst::Action objects (using $self->create_action) for them and
412 registers them with $c->dispatcher.
414 =head2 $self->action_namespace($c)
416 Returns the private namespace for actions in this component. Defaults
417 to a value from the controller name (for
418 e.g. MyApp::Controller::Foo::Bar becomes "foo/bar") or can be
419 overridden from the "namespace" config key.
422 =head2 $self->path_prefix($c)
424 Returns the default path prefix for :Local, :LocalRegex and relative
425 :Path actions in this component. Defaults to the action_namespace or
426 can be overridden from the "path" config key.
428 =head2 $self->create_action(%args)
430 Called with a hash of data to be use for construction of a new
431 Catalyst::Action (or appropriate sub/alternative class) object.
433 Primarily designed for the use of register_actions.
435 =head2 $self->_application
439 Returns the application instance stored by C<new()>
443 Sebastian Riedel, C<sri@oook.de>
444 Marcus Ramberg C<mramberg@cpan.org>
448 This program is free software, you can redistribute it and/or modify
449 it under the same terms as Perl itself.