lib/Catalyst/Controller.pm

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