lib/Catalyst/Controller.pm

   1 package Catalyst::Controller;
   2
   3 use strict;
   4 use base qw/Catalyst::Component Catalyst::AttrContainer Class::Accessor::Fast/;
   5
   6 use Catalyst::Exception;
   7 use Catalyst::Utils;
   8 use Class::Inspector;
   9 use NEXT;
  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
  28 reside. Each action is represented by a function with an attribute to
  29 identify what kind of action it is. See the L<Catalyst::Dispatcher>
  30 for more info about how 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 sub _DISPATCH : Private {
  45     my ( $self, $c ) = @_;
  46
  47     foreach my $disp ( @{ $self->_dispatch_steps } ) {
  48         last unless $c->forward($disp);
  49     }
  50
  51     $c->forward('_END');
  52 }
  53
  54 sub _BEGIN : Private {
  55     my ( $self, $c ) = @_;
  56     my $begin = ( $c->get_actions( 'begin', $c->namespace ) )[-1];
  57     return 1 unless $begin;
  58     $begin->dispatch( $c );
  59     return !@{ $c->error };
  60 }
  61
  62 sub _AUTO : Private {
  63     my ( $self, $c ) = @_;
  64     my @auto = $c->get_actions( 'auto', $c->namespace );
  65     foreach my $auto (@auto) {
  66         $auto->dispatch( $c );
  67         return 0 unless $c->state;
  68     }
  69     return 1;
  70 }
  71
  72 sub _ACTION : Private {
  73     my ( $self, $c ) = @_;
  74     if (   ref $c->action
  75         && $c->action->can('execute')
  76         && defined $c->req->action )
  77     {
  78         $c->action->dispatch( $c );
  79     }
  80     return !@{ $c->error };
  81 }
  82
  83 sub _END : Private {
  84     my ( $self, $c ) = @_;
  85     my $end = ( $c->get_actions( 'end', $c->namespace ) )[-1];
  86     return 1 unless $end;
  87     $end->dispatch( $c );
  88     return !@{ $c->error };
  89 }
  90
  91 sub new {
  92     my $self = shift;
  93     my $app = $_[0];
  94     my $new = $self->NEXT::new(@_);
  95     $new->_application( $app );
  96     return $new;
  97 }
  98
  99
 100 sub action_for {
 101     my ( $self, $name ) = @_;
 102     my $app = ($self->isa('Catalyst') ? $self : $self->_application);
 103     return $app->dispatcher->get_action($name, $self->action_namespace);
 104 }
 105
 106 sub action_namespace {
 107     my ( $self, $c ) = @_;
 108     unless ( $c ) {
 109         $c = ($self->isa('Catalyst') ? $self : $self->_application);
 110     }
 111     my $hash = (ref $self ? $self : $self->config); # hate app-is-class
 112     return $hash->{namespace} if exists $hash->{namespace};
 113     return Catalyst::Utils::class2prefix( ref($self) || $self,
 114         $c->config->{case_sensitive} )
 115       || '';
 116 }
 117
 118 sub path_prefix {
 119     my ( $self, $c ) = @_;
 120     unless ( $c ) {
 121         $c = ($self->isa('Catalyst') ? $self : $self->_application);
 122     }
 123     my $hash = (ref $self ? $self : $self->config); # hate app-is-class
 124     return $hash->{path} if exists $hash->{path};
 125     return shift->action_namespace(@_);
 126 }
 127
 128
 129 sub register_actions {
 130     my ( $self, $c ) = @_;
 131     my $class = ref $self || $self;
 132     my $namespace = $self->action_namespace($c);
 133     my %methods;
 134     $methods{ $self->can($_) } = $_
 135       for @{ Class::Inspector->methods($class) || [] };
 136
 137     # Advanced inheritance support for plugins and the like
 138     my @action_cache;
 139     {
 140         no strict 'refs';
 141         for my $isa ( @{"$class\::ISA"}, $class ) {
 142             push @action_cache, @{ $isa->_action_cache }
 143               if $isa->can('_action_cache');
 144         }
 145     }
 146
 147     foreach my $cache (@action_cache) {
 148         my $code   = $cache->[0];
 149         my $method = delete $methods{$code}; # avoid dupe registers
 150         next unless $method;
 151         my $attrs = $self->_parse_attrs( $c, $method, @{ $cache->[1] } );
 152         if ( $attrs->{Private} && ( keys %$attrs > 1 ) ) {
 153             $c->log->debug( 'Bad action definition "'
 154                   . join( ' ', @{ $cache->[1] } )
 155                   . qq/" for "$class->$method"/ )
 156               if $c->debug;
 157             next;
 158         }
 159         my $reverse = $namespace ? "$namespace/$method" : $method;
 160         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         $c->dispatcher->register( $c, $action );
 170     }
 171 }
 172
 173 sub create_action {
 174     my $self = shift;
 175     my %args = @_;
 176
 177     my $class = (exists $args{attributes}{ActionClass}
 178                     ? $args{attributes}{ActionClass}[0]
 179                     : $self->_action_class);
 180
 181     unless ( Class::Inspector->loaded($class) ) {
 182         require Class::Inspector->filename($class);
 183     }
 184
 185     return $class->new( \%args );
 186 }
 187
 188 sub _parse_attrs {
 189     my ( $self, $c, $name, @attrs ) = @_;
 190
 191     my %raw_attributes;
 192
 193     foreach my $attr (@attrs) {
 194
 195         # Parse out :Foo(bar) into Foo => bar etc (and arrayify)
 196
 197         if ( my ( $key, $value ) = ( $attr =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ ) )
 198         {
 199
 200             if ( defined $value ) {
 201                 ( $value =~ s/^'(.*)'$/$1/ ) || ( $value =~ s/^"(.*)"/$1/ );
 202             }
 203             push( @{ $raw_attributes{$key} }, $value );
 204         }
 205     }
 206
 207     my $hash = (ref $self ? $self : $self->config); # hate app-is-class
 208
 209     if (exists $hash->{actions} || exists $hash->{action}) {
 210       my $a = $hash->{actions} || $hash->{action};
 211       %raw_attributes = ((exists $a->{'*'} ? %{$a->{'*'}} : ()),
 212                          %raw_attributes,
 213                          (exists $a->{$name} ? %{$a->{$name}} : ()));
 214     }
 215
 216     my %final_attributes;
 217
 218     foreach my $key (keys %raw_attributes) {
 219
 220         my $raw = $raw_attributes{$key};
 221
 222         foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) {
 223
 224             my $meth = "_parse_${key}_attr";
 225             if ( $self->can($meth) ) {
 226                 ( $key, $value ) = $self->$meth( $c, $name, $value );
 227             }
 228             push( @{ $final_attributes{$key} }, $value );
 229         }
 230     }
 231
 232     return \%final_attributes;
 233 }
 234
 235 sub _parse_Global_attr {
 236     my ( $self, $c, $name, $value ) = @_;
 237     return $self->_parse_Path_attr( $c, $name, "/$name" );
 238 }
 239
 240 sub _parse_Absolute_attr { shift->_parse_Global_attr(@_); }
 241
 242 sub _parse_Local_attr {
 243     my ( $self, $c, $name, $value ) = @_;
 244     return $self->_parse_Path_attr( $c, $name, $name );
 245 }
 246
 247 sub _parse_Relative_attr { shift->_parse_Local_attr(@_); }
 248
 249 sub _parse_Path_attr {
 250     my ( $self, $c, $name, $value ) = @_;
 251     $value = '' if !defined $value;
 252     if ( $value =~ m!^/! ) {
 253         return ( 'Path', $value );
 254     }
 255     elsif ( length $value ) {
 256         return ( 'Path', join( '/', $self->path_prefix($c), $value ) );
 257     }
 258     else {
 259         return ( 'Path', $self->path_prefix($c) );
 260     }
 261 }
 262
 263 sub _parse_Regex_attr {
 264     my ( $self, $c, $name, $value ) = @_;
 265     return ( 'Regex', $value );
 266 }
 267
 268 sub _parse_Regexp_attr { shift->_parse_Regex_attr(@_); }
 269
 270 sub _parse_LocalRegex_attr {
 271     my ( $self, $c, $name, $value ) = @_;
 272     unless ( $value =~ s/^\^// ) { $value = "(?:.*?)$value"; }
 273
 274     my $prefix = $self->path_prefix( $c );
 275     $prefix .= '/' if length( $prefix );
 276
 277     return ( 'Regex', "^${prefix}${value}" );
 278 }
 279
 280 sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); }
 281
 282 sub _parse_Chained_attr {
 283     my ($self, $c, $name, $value) = @_;
 284
 285     if (defined($value) && length($value)) {
 286         if ($value eq '.') {
 287             $value = '/'.$self->action_namespace($c);
 288         } elsif (my ($rest) = $value =~ /^\.{2}\/(.*)$/) {
 289             my @parts = split '/', $self->action_namespace($c);
 290             $value = '/'.join('/', @parts[0 .. $#parts-1], $rest);
 291         } elsif ($value !~ m/^\//) {
 292             my $action_ns = $self->action_namespace($c);
 293
 294             if ($action_ns) {
 295                 $value = '/'.join('/', $action_ns, $value);
 296             } else {
 297                 $value = '/'.$value; # special case namespace '' (root)
 298             }
 299         }
 300     } else {
 301         $value = '/'
 302     }
 303
 304     return Chained => $value;
 305 }
 306
 307 sub _parse_ChainedParent_attr {
 308     my ($self, $c, $name, $value) = @_;
 309     return $self->_parse_Chained_attr($c, $name, '../'.$name);
 310 }
 311
 312 sub _parse_PathPrefix_attr {
 313     my $self = shift;
 314     return PathPart => $self->path_prefix;
 315 }
 316
 317 sub _parse_ActionClass_attr {
 318     my ( $self, $c, $name, $value ) = @_;
 319     unless ( $value =~ s/^\+// ) {
 320       $value = join('::', $self->_action_class, $value );
 321     }
 322     return ( 'ActionClass', $value );
 323 }
 324
 325 sub _parse_MyAction_attr {
 326     my ( $self, $c, $name, $value ) = @_;
 327
 328     my $appclass = Catalyst::Utils::class2appclass($self);
 329     $value = "${appclass}::Action::${value}";
 330
 331     return ( 'ActionClass', $value );
 332 }
 333
 334 1;
 335
 336 __END__
 337
 338 =head1 CONFIGURATION
 339
 340 Like any other L<Catalyst::Component>, controllers have a config hash,
 341 accessible through $self->config from the controller actions.  Some
 342 settings are in use by the Catalyst framework:
 343
 344 =head2 namespace
 345
 346 This specifies the internal namespace the controller should be bound
 347 to. By default the controller is bound to the URI version of the
 348 controller name. For instance controller 'MyApp::Controller::Foo::Bar'
 349 will be bound to 'foo/bar'. The default Root controller is an example
 350 of setting namespace to '' (the null string).
 351
 352 =head2 path
 353
 354 Sets 'path_prefix', as described below.
 355
 356 =head1 METHODS
 357
 358 =head2 $class->new($app, @args)
 359
 360 Proxies through to NEXT::new and stashes the application instance as
 361 $self->_application.
 362
 363 =head2 $self->action_for('name')
 364
 365 Returns the Catalyst::Action object (if any) for a given method name
 366 in this component.
 367
 368 =head2 $self->register_actions($c)
 369
 370 Finds all applicable actions for this component, creates
 371 Catalyst::Action objects (using $self->create_action) for them and
 372 registers them with $c->dispatcher.
 373
 374 =head2 $self->action_namespace($c)
 375
 376 Returns the private namespace for actions in this component. Defaults
 377 to a value from the controller name (for
 378 e.g. MyApp::Controller::Foo::Bar becomes "foo/bar") or can be
 379 overridden from the "namespace" config key.
 380
 381
 382 =head2 $self->path_prefix($c)
 383
 384 Returns the default path prefix for :PathPrefix, :Local, :LocalRegex and
 385 relative :Path actions in this component. Defaults to the action_namespace or
 386 can be overridden from the "path" config key.
 387
 388 =head2 $self->create_action(%args)
 389
 390 Called with a hash of data to be use for construction of a new
 391 Catalyst::Action (or appropriate sub/alternative class) object.
 392
 393 Primarily designed for the use of register_actions.
 394
 395 =head2 $self->_application
 396
 397 =head2 $self->_app
 398
 399 Returns the application instance stored by C<new()>
 400
 401 =head1 AUTHORS
 402
 403 Catalyst Contributors, see Catalyst.pm
 404
 405 =head1 COPYRIGHT
 406
 407 This program is free software, you can redistribute it and/or modify
 408 it under the same terms as Perl itself.
 409
 410 =cut