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', # 5.7 compat
  21      predicate => 'has_path_prefix',
  22     );
  23
  24 has action_namespace =>
  25     (
  26      is => 'rw',
  27      isa => 'Str',
  28      init_arg => 'namespace', # 5.7 compat
  29      predicate => 'has_action_namespace',
  30     );
  31
  32 has _controller_actions =>
  33     (
  34      is => 'rw',
  35      isa => 'HashRef',
  36      init_arg => 'action', # 5.7 compat
  37     );
  38
  39 around BUILDARGS => sub { # Icky 5.7 compat
  40     my $orig = shift;
  41     my $self = shift;
  42     my $args = $self->$orig(@_);
  43     my $action  = delete $args->{action}  || {};
  44     my $actions = delete $args->{actions} || {};
  45     $args->{action} = $self->merge_config_hashes($actions, $action);
  46     return $args;
  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(ref($self) || $self, $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 for " . ref($meta) ." for " . $meta->name
 184         . " cannot support register_actions.")
 185         unless $meta->can('get_nearest_methods_with_attributes');
 186     my @methods = $meta->get_nearest_methods_with_attributes;
 187     return @methods;
 188 }
 189
 190 sub register_actions {
 191     my ( $self, $c ) = @_;
 192     $self->register_action_methods( $c, $self->get_action_methods );
 193 }
 194
 195 sub register_action_methods {
 196     my ( $self, $c, @methods ) = @_;
 197     my $class = ref $self || $self;
 198     #this is still not correct for some reason.
 199     my $namespace = $self->action_namespace($c);
 200
 201     foreach my $method (@methods) {
 202         my $name = $method->name;
 203         my $attributes = $method->attributes;
 204         next unless $attributes;
 205         my $attrs = $self->_parse_attrs( $c, $name, @{ $attributes } );
 206         if ( $attrs->{Private} && ( keys %$attrs > 1 ) ) {
 207             $c->log->debug( 'Bad action definition "'
 208                   . join( ' ', @{ $attributes } )
 209                   . qq/" for "$class->$name"/ )
 210               if $c->debug;
 211             next;
 212         }
 213         my $reverse = $namespace ? "${namespace}/${name}" : $name;
 214         my $action = $self->create_action(
 215             name       => $name,
 216             code       => $method->body,
 217             reverse    => $reverse,
 218             namespace  => $namespace,
 219             class      => $class,
 220             attributes => $attrs,
 221         );
 222
 223         $c->dispatcher->register( $c, $action );
 224     }
 225 }
 226
 227 sub create_action {
 228     my $self = shift;
 229     my %args = @_;
 230
 231     my $class = (exists $args{attributes}{ActionClass}
 232                     ? $args{attributes}{ActionClass}[0]
 233                     : $self->_action_class);
 234
 235     Class::MOP::load_class($class);
 236     return $class->new( \%args );
 237 }
 238
 239 sub _parse_attrs {
 240     my ( $self, $c, $name, @attrs ) = @_;
 241
 242     my %raw_attributes;
 243
 244     foreach my $attr (@attrs) {
 245
 246         # Parse out :Foo(bar) into Foo => bar etc (and arrayify)
 247
 248         if ( my ( $key, $value ) = ( $attr =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ ) )
 249         {
 250
 251             if ( defined $value ) {
 252                 ( $value =~ s/^'(.*)'$/$1/ ) || ( $value =~ s/^"(.*)"/$1/ );
 253             }
 254             push( @{ $raw_attributes{$key} }, $value );
 255         }
 256     }
 257
 258     #I know that the original behavior was to ignore action if actions was set
 259     # but i actually think this may be a little more sane? we can always remove
 260     # the merge behavior quite easily and go back to having actions have
 261     # presedence over action by modifying the keys. i honestly think this is
 262     # superior while mantaining really high degree of compat
 263     my $actions;
 264     if( ref($self) ) {
 265         $actions = $self->_controller_actions;
 266     } else {
 267         my $cfg = $self->config;
 268         $actions = $self->merge_config_hashes($cfg->{actions}, $cfg->{action});
 269     }
 270
 271     %raw_attributes = ((exists $actions->{'*'} ? %{$actions->{'*'}} : ()),
 272                        %raw_attributes,
 273                        (exists $actions->{$name} ? %{$actions->{$name}} : ()));
 274
 275
 276     my %final_attributes;
 277
 278     foreach my $key (keys %raw_attributes) {
 279
 280         my $raw = $raw_attributes{$key};
 281
 282         foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) {
 283
 284             my $meth = "_parse_${key}_attr";
 285             if ( my $code = $self->can($meth) ) {
 286                 ( $key, $value ) = $self->$code( $c, $name, $value );
 287             }
 288             push( @{ $final_attributes{$key} }, $value );
 289         }
 290     }
 291
 292     return \%final_attributes;
 293 }
 294
 295 sub _parse_Global_attr {
 296     my ( $self, $c, $name, $value ) = @_;
 297     return $self->_parse_Path_attr( $c, $name, "/$name" );
 298 }
 299
 300 sub _parse_Absolute_attr { shift->_parse_Global_attr(@_); }
 301
 302 sub _parse_Local_attr {
 303     my ( $self, $c, $name, $value ) = @_;
 304     return $self->_parse_Path_attr( $c, $name, $name );
 305 }
 306
 307 sub _parse_Relative_attr { shift->_parse_Local_attr(@_); }
 308
 309 sub _parse_Path_attr {
 310     my ( $self, $c, $name, $value ) = @_;
 311     $value = '' if !defined $value;
 312     if ( $value =~ m!^/! ) {
 313         return ( 'Path', $value );
 314     }
 315     elsif ( length $value ) {
 316         return ( 'Path', join( '/', $self->path_prefix($c), $value ) );
 317     }
 318     else {
 319         return ( 'Path', $self->path_prefix($c) );
 320     }
 321 }
 322
 323 sub _parse_Regex_attr {
 324     my ( $self, $c, $name, $value ) = @_;
 325     return ( 'Regex', $value );
 326 }
 327
 328 sub _parse_Regexp_attr { shift->_parse_Regex_attr(@_); }
 329
 330 sub _parse_LocalRegex_attr {
 331     my ( $self, $c, $name, $value ) = @_;
 332     unless ( $value =~ s/^\^// ) { $value = "(?:.*?)$value"; }
 333
 334     my $prefix = $self->path_prefix( $c );
 335     $prefix .= '/' if length( $prefix );
 336
 337     return ( 'Regex', "^${prefix}${value}" );
 338 }
 339
 340 sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); }
 341
 342 sub _parse_Chained_attr {
 343     my ($self, $c, $name, $value) = @_;
 344
 345     if (defined($value) && length($value)) {
 346         if ($value eq '.') {
 347             $value = '/'.$self->action_namespace($c);
 348         } elsif (my ($rel, $rest) = $value =~ /^((?:\.{2}\/)+)(.*)$/) {
 349             my @parts = split '/', $self->action_namespace($c);
 350             my @levels = split '/', $rel;
 351
 352             $value = '/'.join('/', @parts[0 .. $#parts - @levels], $rest);
 353         } elsif ($value !~ m/^\//) {
 354             my $action_ns = $self->action_namespace($c);
 355
 356             if ($action_ns) {
 357                 $value = '/'.join('/', $action_ns, $value);
 358             } else {
 359                 $value = '/'.$value; # special case namespace '' (root)
 360             }
 361         }
 362     } else {
 363         $value = '/'
 364     }
 365
 366     return Chained => $value;
 367 }
 368
 369 sub _parse_ChainedParent_attr {
 370     my ($self, $c, $name, $value) = @_;
 371     return $self->_parse_Chained_attr($c, $name, '../'.$name);
 372 }
 373
 374 sub _parse_PathPrefix_attr {
 375     my $self = shift;
 376     return PathPart => $self->path_prefix;
 377 }
 378
 379 sub _parse_ActionClass_attr {
 380     my ( $self, $c, $name, $value ) = @_;
 381     unless ( $value =~ s/^\+// ) {
 382       $value = join('::', $self->_action_class, $value );
 383     }
 384     return ( 'ActionClass', $value );
 385 }
 386
 387 sub _parse_MyAction_attr {
 388     my ( $self, $c, $name, $value ) = @_;
 389
 390     my $appclass = Catalyst::Utils::class2appclass($self);
 391     $value = "${appclass}::Action::${value}";
 392
 393     return ( 'ActionClass', $value );
 394 }
 395
 396 __PACKAGE__->meta->make_immutable;
 397
 398 1;
 399
 400 __END__
 401
 402 =head1 CONFIGURATION
 403
 404 Like any other L<Catalyst::Component>, controllers have a config hash,
 405 accessible through $self->config from the controller actions.  Some
 406 settings are in use by the Catalyst framework:
 407
 408 =head2 namespace
 409
 410 This specifies the internal namespace the controller should be bound
 411 to. By default the controller is bound to the URI version of the
 412 controller name. For instance controller 'MyApp::Controller::Foo::Bar'
 413 will be bound to 'foo/bar'. The default Root controller is an example
 414 of setting namespace to '' (the null string).
 415
 416 =head2 path
 417
 418 Sets 'path_prefix', as described below.
 419
 420 =head1 METHODS
 421
 422 =head2 BUILDARGS ($app, @args)
 423
 424 From L<Catalyst::Component::ApplicationAttribute>, stashes the application
 425 instance as $self->_application.
 426
 427 =head2 $self->action_for('name')
 428
 429 Returns the Catalyst::Action object (if any) for a given method name
 430 in this component.
 431
 432 =head2 $self->action_namespace($c)
 433
 434 Returns the private namespace for actions in this component. Defaults
 435 to a value from the controller name (for
 436 e.g. MyApp::Controller::Foo::Bar becomes "foo/bar") or can be
 437 overridden from the "namespace" config key.
 438
 439
 440 =head2 $self->path_prefix($c)
 441
 442 Returns the default path prefix for :PathPrefix, :Local, :LocalRegex and
 443 relative :Path actions in this component. Defaults to the action_namespace or
 444 can be overridden from the "path" config key.
 445
 446 =head2 $self->register_actions($c)
 447
 448 Finds all applicable actions for this component, creates
 449 Catalyst::Action objects (using $self->create_action) for them and
 450 registers them with $c->dispatcher.
 451
 452 =head2 $self->get_action_methods()
 453
 454 Returns a list of L<Moose::Meta::Method> objects, doing the
 455 L<MooseX::MethodAttributes::Role::Meta::Method> role, which are the set of
 456 action methods for this package.
 457
 458 =head2 $self->register_action_methods($c, @methods)
 459
 460 Creates action objects for a set of action methods using C< create_action >,
 461 and registers them with the dispatcher.
 462
 463 =head2 $self->create_action(%args)
 464
 465 Called with a hash of data to be use for construction of a new
 466 Catalyst::Action (or appropriate sub/alternative class) object.
 467
 468 =head2 $self->_application
 469
 470 =head2 $self->_app
 471
 472 Returns the application instance stored by C<new()>
 473
 474 =head1 AUTHORS
 475
 476 Catalyst Contributors, see Catalyst.pm
 477
 478 =head1 COPYRIGHT
 479
 480 This program is free software, you can redistribute it and/or modify
 481 it under the same terms as Perl itself.
 482
 483 =cut