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