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