lib/Catalyst/Controller.pm

   1 package Catalyst::Controller;
   2
   3 use Moose;
   4 # Note - Must be done at compile time due to attributes (::AttrContainer)
   5 BEGIN { extends qw/Catalyst::Component Catalyst::AttrContainer/; }
   6
   7 use Class::MOP::Object ();
   8 use Catalyst::Exception;
   9 use Catalyst::Utils;
  10
  11 with 'Catalyst::Component::ApplicationAttribute';
  12
  13 has path_prefix =>
  14     (
  15      is => 'rw',
  16      isa => 'Str',
  17      init_arg => 'path',
  18      predicate => 'has_path_prefix',
  19     );
  20
  21 has action_namespace =>
  22     (
  23      is => 'rw',
  24      isa => 'Str',
  25      init_arg => 'namespace',
  26      predicate => 'has_action_namespace',
  27     );
  28
  29 has actions =>
  30     (
  31      is => 'rw',
  32      isa => 'HashRef',
  33      init_arg => undef,
  34     );
  35
  36 sub BUILD {
  37     my ($self, $args) = @_;
  38     my $action  = delete $args->{action}  || {};
  39     my $actions = delete $args->{actions} || {};
  40     my $attr_value = $self->merge_config_hashes($actions, $action);
  41     $self->actions($attr_value);
  42 }
  43
  44 =head1 NAME
  45
  46 Catalyst::Controller - Catalyst Controller base class
  47
  48 =head1 SYNOPSIS
  49
  50   package MyApp::Controller::Search
  51   use base qw/Catalyst::Controller/;
  52
  53   sub foo : Local {
  54     my ($self,$c,@args) = @_;
  55     ...
  56   } # Dispatches to /search/foo
  57
  58 =head1 DESCRIPTION
  59
  60 Controllers are where the actions in the Catalyst framework
  61 reside. Each action is represented by a function with an attribute to
  62 identify what kind of action it is. See the L<Catalyst::Dispatcher>
  63 for more info about how Catalyst dispatches to actions.
  64
  65 =cut
  66
  67 #I think both of these could be attributes. doesn't really seem like they need
  68 #to ble class data. i think that attributes +default would work just fine
  69 __PACKAGE__->mk_classdata($_) for qw/_dispatch_steps _action_class/;
  70
  71 __PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] );
  72 __PACKAGE__->_action_class('Catalyst::Action');
  73
  74
  75 sub _DISPATCH : Private {
  76     my ( $self, $c ) = @_;
  77
  78     foreach my $disp ( @{ $self->_dispatch_steps } ) {
  79         last unless $c->forward($disp);
  80     }
  81
  82     $c->forward('_END');
  83 }
  84
  85 sub _BEGIN : Private {
  86     my ( $self, $c ) = @_;
  87     my $begin = ( $c->get_actions( 'begin', $c->namespace ) )[-1];
  88     return 1 unless $begin;
  89     $begin->dispatch( $c );
  90     return !@{ $c->error };
  91 }
  92
  93 sub _AUTO : Private {
  94     my ( $self, $c ) = @_;
  95     my @auto = $c->get_actions( 'auto', $c->namespace );
  96     foreach my $auto (@auto) {
  97         $auto->dispatch( $c );
  98         return 0 unless $c->state;
  99     }
 100     return 1;
 101 }
 102
 103 sub _ACTION : Private {
 104     my ( $self, $c ) = @_;
 105     if (   ref $c->action
 106         && $c->action->can('execute')
 107         && defined $c->req->action )
 108     {
 109         $c->action->dispatch( $c );
 110     }
 111     return !@{ $c->error };
 112 }
 113
 114 sub _END : Private {
 115     my ( $self, $c ) = @_;
 116     my $end = ( $c->get_actions( 'end', $c->namespace ) )[-1];
 117     return 1 unless $end;
 118     $end->dispatch( $c );
 119     return !@{ $c->error };
 120 }
 121
 122 sub action_for {
 123     my ( $self, $name ) = @_;
 124     my $app = ($self->isa('Catalyst') ? $self : $self->_application);
 125     return $app->dispatcher->get_action($name, $self->action_namespace);
 126 }
 127
 128 #my opinion is that this whole sub really should be a builder method, not
 129 #something that happens on every call. Anyone else disagree?? -- groditi
 130 ## -- apparently this is all just waiting for app/ctx split
 131 around action_namespace => sub {
 132     my $orig = shift;
 133     my ( $self, $c ) = @_;
 134
 135     if( ref($self) ){
 136         return $self->$orig if $self->has_action_namespace;
 137     } else {
 138         return $self->config->{namespace} if exists $self->config->{namespace};
 139     }
 140
 141     my $case_s;
 142     if( $c ){
 143         $case_s = $c->config->{case_sensitive};
 144     } else {
 145         if ($self->isa('Catalyst')) {
 146             $case_s = $self->config->{case_sensitive};
 147         } else {
 148             if (ref $self) {
 149                 $case_s = $self->_application->config->{case_sensitive};
 150             } else {
 151                 confess("Can't figure out case_sensitive setting");
 152             }
 153         }
 154     }
 155
 156     my $namespace = Catalyst::Utils::class2prefix(ref($self) || $self, $case_s) || '';
 157     $self->$orig($namespace) if ref($self);
 158     return $namespace;
 159 };
 160
 161 #Once again, this is probably better written as a builder method
 162 around path_prefix => sub {
 163     my $orig = shift;
 164     my $self = shift;
 165     if( ref($self) ){
 166       return $self->$orig if $self->has_path_prefix;
 167     } else {
 168       return $self->config->{path} if exists $self->config->{path};
 169     }
 170     my $namespace = $self->action_namespace(@_);
 171     $self->$orig($namespace) if ref($self);
 172     return $namespace;
 173 };
 174
 175
 176 sub register_actions {
 177     my ( $self, $c ) = @_;
 178     my $class = ref $self || $self;
 179     #this is still not correct for some reason.
 180     my $namespace = $self->action_namespace($c);
 181     my $meta = $self->Class::MOP::Object::meta();
 182     my %methods = map { $_->body => $_->name }
 183         grep { $_->package_name ne 'Moose::Object' } #ignore Moose::Object methods
 184             $meta->get_all_methods;
 185
 186     # Advanced inheritance support for plugins and the like
 187     #moose todo: migrate to eliminate CDI compat
 188     my @action_cache;
 189     for my $isa ( $meta->superclasses, $class ) {
 190         if(my $coderef = $isa->can('_action_cache')){
 191             push(@action_cache, @{ $isa->$coderef });
 192         }
 193     }
 194
 195     foreach my $cache (@action_cache) {
 196         my $code   = $cache->[0];
 197         my $method = delete $methods{$code}; # avoid dupe registers
 198         next unless $method;
 199         my $attrs = $self->_parse_attrs( $c, $method, @{ $cache->[1] } );
 200         if ( $attrs->{Private} && ( keys %$attrs > 1 ) ) {
 201             $c->log->debug( 'Bad action definition "'
 202                   . join( ' ', @{ $cache->[1] } )
 203                   . qq/" for "$class->$method"/ )
 204               if $c->debug;
 205             next;
 206         }
 207         my $reverse = $namespace ? "${namespace}/${method}" : $method;
 208         my $action = $self->create_action(
 209             name       => $method,
 210             code       => $code,
 211             reverse    => $reverse,
 212             namespace  => $namespace,
 213             class      => $class,
 214             attributes => $attrs,
 215         );
 216
 217         $c->dispatcher->register( $c, $action );
 218     }
 219 }
 220
 221 sub create_action {
 222     my $self = shift;
 223     my %args = @_;
 224
 225     my $class = (exists $args{attributes}{ActionClass}
 226                     ? $args{attributes}{ActionClass}[0]
 227                     : $self->_action_class);
 228
 229     Class::MOP::load_class($class);
 230     return $class->new( \%args );
 231 }
 232
 233 sub _parse_attrs {
 234     my ( $self, $c, $name, @attrs ) = @_;
 235
 236     my %raw_attributes;
 237
 238     foreach my $attr (@attrs) {
 239
 240         # Parse out :Foo(bar) into Foo => bar etc (and arrayify)
 241
 242         if ( my ( $key, $value ) = ( $attr =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ ) )
 243         {
 244
 245             if ( defined $value ) {
 246                 ( $value =~ s/^'(.*)'$/$1/ ) || ( $value =~ s/^"(.*)"/$1/ );
 247             }
 248             push( @{ $raw_attributes{$key} }, $value );
 249         }
 250     }
 251
 252     #I know that the original behavior was to ignore action if actions was set
 253     # but i actually think this may be a little more sane? we can always remove
 254     # the merge behavior quite easily and go back to having actions have
 255     # presedence over action by modifying the keys. i honestly think this is
 256     # superior while mantaining really high degree of compat
 257     my $actions;
 258     if( ref($self) ) {
 259         $actions = $self->actions;
 260     } else {
 261         my $cfg = $self->config;
 262         $actions = $self->merge_config_hashes($cfg->{actions}, $cfg->{action});
 263     }
 264
 265     %raw_attributes = ((exists $actions->{'*'} ? %{$actions->{'*'}} : ()),
 266                        %raw_attributes,
 267                        (exists $actions->{$name} ? %{$actions->{$name}} : ()));
 268
 269
 270     my %final_attributes;
 271
 272     foreach my $key (keys %raw_attributes) {
 273
 274         my $raw = $raw_attributes{$key};
 275
 276         foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) {
 277
 278             my $meth = "_parse_${key}_attr";
 279             if ( my $code = $self->can($meth) ) {
 280                 ( $key, $value ) = $self->$code( $c, $name, $value );
 281             }
 282             push( @{ $final_attributes{$key} }, $value );
 283         }
 284     }
 285
 286     return \%final_attributes;
 287 }
 288
 289 sub _parse_Global_attr {
 290     my ( $self, $c, $name, $value ) = @_;
 291     return $self->_parse_Path_attr( $c, $name, "/$name" );
 292 }
 293
 294 sub _parse_Absolute_attr { shift->_parse_Global_attr(@_); }
 295
 296 sub _parse_Local_attr {
 297     my ( $self, $c, $name, $value ) = @_;
 298     return $self->_parse_Path_attr( $c, $name, $name );
 299 }
 300
 301 sub _parse_Relative_attr { shift->_parse_Local_attr(@_); }
 302
 303 sub _parse_Path_attr {
 304     my ( $self, $c, $name, $value ) = @_;
 305     $value = '' if !defined $value;
 306     if ( $value =~ m!^/! ) {
 307         return ( 'Path', $value );
 308     }
 309     elsif ( length $value ) {
 310         return ( 'Path', join( '/', $self->path_prefix($c), $value ) );
 311     }
 312     else {
 313         return ( 'Path', $self->path_prefix($c) );
 314     }
 315 }
 316
 317 sub _parse_Regex_attr {
 318     my ( $self, $c, $name, $value ) = @_;
 319     return ( 'Regex', $value );
 320 }
 321
 322 sub _parse_Regexp_attr { shift->_parse_Regex_attr(@_); }
 323
 324 sub _parse_LocalRegex_attr {
 325     my ( $self, $c, $name, $value ) = @_;
 326     unless ( $value =~ s/^\^// ) { $value = "(?:.*?)$value"; }
 327
 328     my $prefix = $self->path_prefix( $c );
 329     $prefix .= '/' if length( $prefix );
 330
 331     return ( 'Regex', "^${prefix}${value}" );
 332 }
 333
 334 sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); }
 335
 336 sub _parse_Chained_attr {
 337     my ($self, $c, $name, $value) = @_;
 338
 339     if (defined($value) && length($value)) {
 340         if ($value eq '.') {
 341             $value = '/'.$self->action_namespace($c);
 342         } elsif (my ($rel, $rest) = $value =~ /^((?:\.{2}\/)+)(.*)$/) {
 343             my @parts = split '/', $self->action_namespace($c);
 344             my @levels = split '/', $rel;
 345
 346             $value = '/'.join('/', @parts[0 .. $#parts - @levels], $rest);
 347         } elsif ($value !~ m/^\//) {
 348             my $action_ns = $self->action_namespace($c);
 349
 350             if ($action_ns) {
 351                 $value = '/'.join('/', $action_ns, $value);
 352             } else {
 353                 $value = '/'.$value; # special case namespace '' (root)
 354             }
 355         }
 356     } else {
 357         $value = '/'
 358     }
 359
 360     return Chained => $value;
 361 }
 362
 363 sub _parse_ChainedParent_attr {
 364     my ($self, $c, $name, $value) = @_;
 365     return $self->_parse_Chained_attr($c, $name, '../'.$name);
 366 }
 367
 368 sub _parse_PathPrefix_attr {
 369     my $self = shift;
 370     return PathPart => $self->path_prefix;
 371 }
 372
 373 sub _parse_ActionClass_attr {
 374     my ( $self, $c, $name, $value ) = @_;
 375     unless ( $value =~ s/^\+// ) {
 376       $value = join('::', $self->_action_class, $value );
 377     }
 378     return ( 'ActionClass', $value );
 379 }
 380
 381 sub _parse_MyAction_attr {
 382     my ( $self, $c, $name, $value ) = @_;
 383
 384     my $appclass = Catalyst::Utils::class2appclass($self);
 385     $value = "${appclass}::Action::${value}";
 386
 387     return ( 'ActionClass', $value );
 388 }
 389
 390 no Moose;
 391
 392 __PACKAGE__->meta->make_immutable;
 393
 394 1;
 395
 396 __END__
 397
 398 =head1 CONFIGURATION
 399
 400 Like any other L<Catalyst::Component>, controllers have a config hash,
 401 accessible through $self->config from the controller actions.  Some
 402 settings are in use by the Catalyst framework:
 403
 404 =head2 namespace
 405
 406 This specifies the internal namespace the controller should be bound
 407 to. By default the controller is bound to the URI version of the
 408 controller name. For instance controller 'MyApp::Controller::Foo::Bar'
 409 will be bound to 'foo/bar'. The default Root controller is an example
 410 of setting namespace to '' (the null string).
 411
 412 =head2 path
 413
 414 Sets 'path_prefix', as described below.
 415
 416 =head1 METHODS
 417
 418 =head2 $class->new($app, @args)
 419
 420 Proxies through to NEXT::new and stashes the application instance as
 421 $self->_application.
 422
 423 =head2 $self->action_for('name')
 424
 425 Returns the Catalyst::Action object (if any) for a given method name
 426 in this component.
 427
 428 =head2 $self->register_actions($c)
 429
 430 Finds all applicable actions for this component, creates
 431 Catalyst::Action objects (using $self->create_action) for them and
 432 registers them with $c->dispatcher.
 433
 434 =head2 $self->action_namespace($c)
 435
 436 Returns the private namespace for actions in this component. Defaults
 437 to a value from the controller name (for
 438 e.g. MyApp::Controller::Foo::Bar becomes "foo/bar") or can be
 439 overridden from the "namespace" config key.
 440
 441
 442 =head2 $self->path_prefix($c)
 443
 444 Returns the default path prefix for :PathPrefix, :Local, :LocalRegex and
 445 relative :Path actions in this component. Defaults to the action_namespace or
 446 can be overridden from the "path" config key.
 447
 448 =head2 $self->create_action(%args)
 449
 450 Called with a hash of data to be use for construction of a new
 451 Catalyst::Action (or appropriate sub/alternative class) object.
 452
 453 Primarily designed for the use of register_actions.
 454
 455 =head2 $self->_application
 456
 457 =head2 $self->_app
 458
 459 Returns the application instance stored by C<new()>
 460
 461 =head1 AUTHORS
 462
 463 Catalyst Contributors, see Catalyst.pm
 464
 465 =head1 COPYRIGHT
 466
 467 This program is free software, you can redistribute it and/or modify
 468 it under the same terms as Perl itself.
 469
 470 =cut