lib/Catalyst/Controller.pm

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