lib/Catalyst/Controller.pm

   1 package Catalyst::Controller;
   2
   3 use Moose;
   4 use Moose::Util qw/find_meta/;
   5 use List::MoreUtils qw/uniq/;
   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 actions =>
  33     (
  34      accessor => '_controller_actions',
  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/;
  75
  76 __PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] );
  77
  78 has _action_class => (
  79     is => 'rw',
  80     default => 'Catalyst::Action',
  81 );
  82
  83 sub _DISPATCH : Private {
  84     my ( $self, $c ) = @_;
  85
  86     foreach my $disp ( @{ $self->_dispatch_steps } ) {
  87         last unless $c->forward($disp);
  88     }
  89
  90     $c->forward('_END');
  91 }
  92
  93 sub _BEGIN : Private {
  94     my ( $self, $c ) = @_;
  95     my $begin = ( $c->get_actions( 'begin', $c->namespace ) )[-1];
  96     return 1 unless $begin;
  97     $begin->dispatch( $c );
  98     return !@{ $c->error };
  99 }
 100
 101 sub _AUTO : Private {
 102     my ( $self, $c ) = @_;
 103     my @auto = $c->get_actions( 'auto', $c->namespace );
 104     foreach my $auto (@auto) {
 105         $auto->dispatch( $c );
 106         return 0 unless $c->state;
 107     }
 108     return 1;
 109 }
 110
 111 sub _ACTION : Private {
 112     my ( $self, $c ) = @_;
 113     if (   ref $c->action
 114         && $c->action->can('execute')
 115         && defined $c->req->action )
 116     {
 117         $c->action->dispatch( $c );
 118     }
 119     return !@{ $c->error };
 120 }
 121
 122 sub _END : Private {
 123     my ( $self, $c ) = @_;
 124     my $end = ( $c->get_actions( 'end', $c->namespace ) )[-1];
 125     return 1 unless $end;
 126     $end->dispatch( $c );
 127     return !@{ $c->error };
 128 }
 129
 130 sub action_for {
 131     my ( $self, $name ) = @_;
 132     my $app = ($self->isa('Catalyst') ? $self : $self->_application);
 133     return $app->dispatcher->get_action($name, $self->action_namespace);
 134 }
 135
 136 #my opinion is that this whole sub really should be a builder method, not
 137 #something that happens on every call. Anyone else disagree?? -- groditi
 138 ## -- apparently this is all just waiting for app/ctx split
 139 around action_namespace => sub {
 140     my $orig = shift;
 141     my ( $self, $c ) = @_;
 142
 143     my $class = ref($self) || $self;
 144     my $appclass = ref($c) || $c;
 145     if( ref($self) ){
 146         return $self->$orig if $self->has_action_namespace;
 147     } else {
 148         return $class->config->{namespace} if exists $class->config->{namespace};
 149     }
 150
 151     my $case_s;
 152     if( $c ){
 153         $case_s = $appclass->config->{case_sensitive};
 154     } else {
 155         if ($self->isa('Catalyst')) {
 156             $case_s = $class->config->{case_sensitive};
 157         } else {
 158             if (ref $self) {
 159                 $case_s = ref($self->_application)->config->{case_sensitive};
 160             } else {
 161                 confess("Can't figure out case_sensitive setting");
 162             }
 163         }
 164     }
 165
 166     my $namespace = Catalyst::Utils::class2prefix($self->catalyst_component_name, $case_s) || '';
 167     $self->$orig($namespace) if ref($self);
 168     return $namespace;
 169 };
 170
 171 #Once again, this is probably better written as a builder method
 172 around path_prefix => sub {
 173     my $orig = shift;
 174     my $self = shift;
 175     if( ref($self) ){
 176       return $self->$orig if $self->has_path_prefix;
 177     } else {
 178       return $self->config->{path} if exists $self->config->{path};
 179     }
 180     my $namespace = $self->action_namespace(@_);
 181     $self->$orig($namespace) if ref($self);
 182     return $namespace;
 183 };
 184
 185 sub get_action_methods {
 186     my $self = shift;
 187     my $meta = find_meta($self) || confess("No metaclass setup for $self");
 188     confess("Metaclass "
 189           . ref($meta) . " for "
 190           . $meta->name
 191           . " cannot support register_actions." )
 192       unless $meta->can('get_nearest_methods_with_attributes');
 193     my @methods = $meta->get_nearest_methods_with_attributes;
 194
 195     # actions specified via config are also action_methods
 196     push(
 197         @methods,
 198         map {
 199             $meta->find_method_by_name($_)
 200               || confess( 'Action "'
 201                   . $_
 202                   . '" is not available from controller '
 203                   . ( ref $self ) )
 204           } keys %{ $self->_controller_actions }
 205     ) if ( ref $self );
 206     return uniq @methods;
 207 }
 208
 209
 210 sub register_actions {
 211     my ( $self, $c ) = @_;
 212     $self->register_action_methods( $c, $self->get_action_methods );
 213 }
 214
 215 sub register_action_methods {
 216     my ( $self, $c, @methods ) = @_;
 217     my $class = $self->catalyst_component_name;
 218     #this is still not correct for some reason.
 219     my $namespace = $self->action_namespace($c);
 220
 221     # FIXME - fugly
 222     if (!blessed($self) && $self eq $c && scalar(@methods)) {
 223         my @really_bad_methods = grep { ! /^_(DISPATCH|BEGIN|AUTO|ACTION|END)$/ } map { $_->name } @methods;
 224         if (scalar(@really_bad_methods)) {
 225             $c->log->warn("Action methods (" . join(', ', @really_bad_methods) . ") found defined in your application class, $self. This is deprecated, please move them into a Root controller.");
 226         }
 227     }
 228
 229     foreach my $method (@methods) {
 230         my $name = $method->name;
 231         my $attributes = $method->attributes;
 232         my $attrs = $self->_parse_attrs( $c, $name, @{ $attributes } );
 233         if ( $attrs->{Private} && ( keys %$attrs > 1 ) ) {
 234             $c->log->debug( 'Bad action definition "'
 235                   . join( ' ', @{ $attributes } )
 236                   . qq/" for "$class->$name"/ )
 237               if $c->debug;
 238             next;
 239         }
 240         my $reverse = $namespace ? "${namespace}/${name}" : $name;
 241         my $action = $self->create_action(
 242             name       => $name,
 243             code       => $method->body,
 244             reverse    => $reverse,
 245             namespace  => $namespace,
 246             class      => $class,
 247             attributes => $attrs,
 248         );
 249
 250         $c->dispatcher->register( $c, $action );
 251     }
 252 }
 253
 254 sub action_class {
 255     my ($self, %args) = @_;
 256
 257     my $class = (exists $args{attributes}{ActionClass}
 258                     ? $args{attributes}{ActionClass}[0]
 259                     : $self->_action_class);
 260     Class::MOP::load_class($class);
 261     return $class;
 262 }
 263
 264 sub create_action {
 265     my $self = shift;
 266     my %args = @_;
 267
 268     my $class = $self->action_class(%args);
 269
 270     my $action_args = $self->config->{action_args};
 271     my %extra_args = (
 272         %{ $action_args->{'*'}           || {} },
 273         %{ $action_args->{ $args{name} } || {} },
 274     );
 275
 276     return $class->new({ %extra_args, %args });
 277 }
 278
 279 sub _parse_attrs {
 280     my ( $self, $c, $name, @attrs ) = @_;
 281
 282     my %raw_attributes;
 283
 284     foreach my $attr (@attrs) {
 285
 286         # Parse out :Foo(bar) into Foo => bar etc (and arrayify)
 287
 288         if ( my ( $key, $value ) = ( $attr =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ ) )
 289         {
 290
 291             if ( defined $value ) {
 292                 ( $value =~ s/^'(.*)'$/$1/ ) || ( $value =~ s/^"(.*)"/$1/ );
 293             }
 294             push( @{ $raw_attributes{$key} }, $value );
 295         }
 296     }
 297
 298     #I know that the original behavior was to ignore action if actions was set
 299     # but i actually think this may be a little more sane? we can always remove
 300     # the merge behavior quite easily and go back to having actions have
 301     # presedence over action by modifying the keys. i honestly think this is
 302     # superior while mantaining really high degree of compat
 303     my $actions;
 304     if( ref($self) ) {
 305         $actions = $self->_controller_actions;
 306     } else {
 307         my $cfg = $self->config;
 308         $actions = $self->merge_config_hashes($cfg->{actions}, $cfg->{action});
 309     }
 310
 311     %raw_attributes = ((exists $actions->{'*'} ? %{$actions->{'*'}} : ()),
 312                        %raw_attributes,
 313                        (exists $actions->{$name} ? %{$actions->{$name}} : ()));
 314
 315
 316     my %final_attributes;
 317
 318     foreach my $key (keys %raw_attributes) {
 319
 320         my $raw = $raw_attributes{$key};
 321
 322         foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) {
 323
 324             my $meth = "_parse_${key}_attr";
 325             if ( my $code = $self->can($meth) ) {
 326                 ( $key, $value ) = $self->$code( $c, $name, $value );
 327             }
 328             push( @{ $final_attributes{$key} }, $value );
 329         }
 330     }
 331
 332     return \%final_attributes;
 333 }
 334
 335 sub _parse_Global_attr {
 336     my ( $self, $c, $name, $value ) = @_;
 337     return $self->_parse_Path_attr( $c, $name, "/$name" );
 338 }
 339
 340 sub _parse_Absolute_attr { shift->_parse_Global_attr(@_); }
 341
 342 sub _parse_Local_attr {
 343     my ( $self, $c, $name, $value ) = @_;
 344     return $self->_parse_Path_attr( $c, $name, $name );
 345 }
 346
 347 sub _parse_Relative_attr { shift->_parse_Local_attr(@_); }
 348
 349 sub _parse_Path_attr {
 350     my ( $self, $c, $name, $value ) = @_;
 351     $value = '' if !defined $value;
 352     if ( $value =~ m!^/! ) {
 353         return ( 'Path', $value );
 354     }
 355     elsif ( length $value ) {
 356         return ( 'Path', join( '/', $self->path_prefix($c), $value ) );
 357     }
 358     else {
 359         return ( 'Path', $self->path_prefix($c) );
 360     }
 361 }
 362
 363 sub _parse_Regex_attr {
 364     my ( $self, $c, $name, $value ) = @_;
 365     return ( 'Regex', $value );
 366 }
 367
 368 sub _parse_Regexp_attr { shift->_parse_Regex_attr(@_); }
 369
 370 sub _parse_LocalRegex_attr {
 371     my ( $self, $c, $name, $value ) = @_;
 372     unless ( $value =~ s/^\^// ) { $value = "(?:.*?)$value"; }
 373
 374     my $prefix = $self->path_prefix( $c );
 375     $prefix .= '/' if length( $prefix );
 376
 377     return ( 'Regex', "^${prefix}${value}" );
 378 }
 379
 380 sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); }
 381
 382 sub _parse_Chained_attr {
 383     my ($self, $c, $name, $value) = @_;
 384
 385     if (defined($value) && length($value)) {
 386         if ($value eq '.') {
 387             $value = '/'.$self->action_namespace($c);
 388         } elsif (my ($rel, $rest) = $value =~ /^((?:\.{2}\/)+)(.*)$/) {
 389             my @parts = split '/', $self->action_namespace($c);
 390             my @levels = split '/', $rel;
 391
 392             $value = '/'.join('/', @parts[0 .. $#parts - @levels], $rest);
 393         } elsif ($value !~ m/^\//) {
 394             my $action_ns = $self->action_namespace($c);
 395
 396             if ($action_ns) {
 397                 $value = '/'.join('/', $action_ns, $value);
 398             } else {
 399                 $value = '/'.$value; # special case namespace '' (root)
 400             }
 401         }
 402     } else {
 403         $value = '/'
 404     }
 405
 406     return Chained => $value;
 407 }
 408
 409 sub _parse_ChainedParent_attr {
 410     my ($self, $c, $name, $value) = @_;
 411     return $self->_parse_Chained_attr($c, $name, '../'.$name);
 412 }
 413
 414 sub _parse_PathPrefix_attr {
 415     my ( $self, $c ) = @_;
 416     return PathPart => $self->path_prefix($c);
 417 }
 418
 419 sub _parse_ActionClass_attr {
 420     my ( $self, $c, $name, $value ) = @_;
 421     my $appname = $self->_application;
 422     $value = Catalyst::Utils::resolve_namespace($appname . '::Action', $self->_action_class, $value);
 423     return ( 'ActionClass', $value );
 424 }
 425
 426 sub _parse_MyAction_attr {
 427     my ( $self, $c, $name, $value ) = @_;
 428
 429     my $appclass = Catalyst::Utils::class2appclass($self);
 430     $value = "${appclass}::Action::${value}";
 431
 432     return ( 'ActionClass', $value );
 433 }
 434
 435 __PACKAGE__->meta->make_immutable;
 436
 437 1;
 438
 439 __END__
 440
 441 =head1 CONFIGURATION
 442
 443 Like any other L<Catalyst::Component>, controllers have a config hash,
 444 accessible through $self->config from the controller actions.  Some
 445 settings are in use by the Catalyst framework:
 446
 447 =head2 namespace
 448
 449 This specifies the internal namespace the controller should be bound
 450 to. By default the controller is bound to the URI version of the
 451 controller name. For instance controller 'MyApp::Controller::Foo::Bar'
 452 will be bound to 'foo/bar'. The default Root controller is an example
 453 of setting namespace to '' (the null string).
 454
 455 =head2 path
 456
 457 Sets 'path_prefix', as described below.
 458
 459 =head2 action
 460
 461 Allows you to set the attributes that the dispatcher creates actions out of.
 462 This allows you to do 'rails style routes', or override some of the
 463 attribute defintions of actions composed from Roles.
 464 You can set arguments globally (for all actions of the controller) and
 465 specifically (for a single action).
 466
 467     __PACKAGE__->config(
 468         action => {
 469             '*' => { Chained => 'base', Args => 0  },
 470             base => { Chained => '/', PathPart => '', CaptureArgs => 0 },
 471         },
 472      );
 473
 474 In the case above every sub in the package would be made into a Chain
 475 endpoint with a URI the same as the sub name for each sub, chained
 476 to the sub named C<base>. Ergo dispatch to C</example> would call the
 477 C<base> method, then the C<example> method.
 478
 479 =head2 action_args
 480
 481 Allows you to set constructor arguments on your actions. You can set arguments
 482 globally and specifically (as above).
 483 This is particularly useful when using C<ActionRole>s
 484 (L<Catalyst::Controller::ActionRole>) and custom C<ActionClass>es.
 485
 486     __PACKAGE__->config(
 487         action_args => {
 488             '*' => { globalarg1 => 'hello', globalarg2 => 'goodbye' },
 489             'specific_action' => { customarg => 'arg1' },
 490         },
 491      );
 492
 493 In the case above the action class associated with C<specific_action> would get
 494 passed the following arguments, in addition to the normal action constructor
 495 arguments, when it is instantiated:
 496
 497   (globalarg1 => 'hello', globalarg2 => 'goodbye', customarg => 'arg1')
 498
 499 =head1 METHODS
 500
 501 =head2 BUILDARGS ($app, @args)
 502
 503 From L<Catalyst::Component::ApplicationAttribute>, stashes the application
 504 instance as $self->_application.
 505
 506 =head2 $self->action_for('name')
 507
 508 Returns the Catalyst::Action object (if any) for a given method name
 509 in this component.
 510
 511 =head2 $self->action_namespace($c)
 512
 513 Returns the private namespace for actions in this component. Defaults
 514 to a value from the controller name (for
 515 e.g. MyApp::Controller::Foo::Bar becomes "foo/bar") or can be
 516 overridden from the "namespace" config key.
 517
 518
 519 =head2 $self->path_prefix($c)
 520
 521 Returns the default path prefix for :PathPrefix, :Local, :LocalRegex and
 522 relative :Path actions in this component. Defaults to the action_namespace or
 523 can be overridden from the "path" config key.
 524
 525 =head2 $self->register_actions($c)
 526
 527 Finds all applicable actions for this component, creates
 528 Catalyst::Action objects (using $self->create_action) for them and
 529 registers them with $c->dispatcher.
 530
 531 =head2 $self->get_action_methods()
 532
 533 Returns a list of L<Moose::Meta::Method> objects, doing the
 534 L<MooseX::MethodAttributes::Role::Meta::Method> role, which are the set of
 535 action methods for this package.
 536
 537 =head2 $self->register_action_methods($c, @methods)
 538
 539 Creates action objects for a set of action methods using C< create_action >,
 540 and registers them with the dispatcher.
 541
 542 =head2 $self->create_action(%args)
 543
 544 Called with a hash of data to be use for construction of a new
 545 Catalyst::Action (or appropriate sub/alternative class) object.
 546
 547 =head2 $self->_application
 548
 549 =head2 $self->_app
 550
 551 Returns the application instance stored by C<new()>
 552
 553 =head1 AUTHORS
 554
 555 Catalyst Contributors, see Catalyst.pm
 556
 557 =head1 COPYRIGHT
 558
 559 This library is free software. You can redistribute it and/or modify
 560 it under the same terms as Perl itself.
 561
 562 =cut