lib/Catalyst/Controller.pm

   1 package Catalyst::Controller;
   2
   3 use Moose;
   4 use base qw/Catalyst::Component Catalyst::AttrContainer/;
   5
   6 #Why does the following blow up?
   7 #extends qw/Catalyst::Component Catalyst::AttrContainer/;
   8
   9 has path => (
  10              is => 'ro',
  11              isa => 'Str',
  12              predicate => 'has_path',
  13             );
  14
  15 #this are frefixed like this because _namespace clases with something in
  16 #Catalyst.pm . to be fixed later.
  17 has _namespace => (
  18                    is => 'ro',
  19                    isa => 'Str',
  20                    init_arg => 'namespace',
  21                    predicate => '_has_namespace',
  22                  );
  23
  24 use Scalar::Util qw/blessed/;
  25 use Catalyst::Exception;
  26 use Catalyst::Utils;
  27 use Class::Inspector;
  28 use NEXT;
  29
  30 =head1 NAME
  31
  32 Catalyst::Controller - Catalyst Controller base class
  33
  34 =head1 SYNOPSIS
  35
  36   package MyApp::Controller::Search
  37   use base qw/Catalyst::Controller/;
  38
  39   sub foo : Local {
  40     my ($self,$c,@args) = @_;
  41     ...
  42   } # Dispatches to /search/foo
  43
  44 =head1 DESCRIPTION
  45
  46 Controllers are where the actions in the Catalyst framework
  47 reside. Each action is represented by a function with an attribute to
  48 identify what kind of action it is. See the L<Catalyst::Dispatcher>
  49 for more info about how Catalyst dispatches to actions.
  50
  51 =cut
  52
  53 __PACKAGE__->mk_classdata($_) for qw/_dispatch_steps _action_class/;
  54
  55 __PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] );
  56 __PACKAGE__->_action_class('Catalyst::Action');
  57
  58 __PACKAGE__->mk_accessors( qw/_application/ );
  59
  60 ### _app as alias
  61 sub _app{ shift->_application }
  62 #for now.
  63 #*_app = *_application;
  64
  65 sub _DISPATCH : Private {
  66     my ( $self, $c ) = @_;
  67
  68     foreach my $disp ( @{ $self->_dispatch_steps } ) {
  69         last unless $c->forward($disp);
  70     }
  71
  72     $c->forward('_END');
  73 }
  74
  75 sub _BEGIN : Private {
  76     my ( $self, $c ) = @_;
  77     my $begin = ( $c->get_actions( 'begin', $c->namespace ) )[-1];
  78     return 1 unless $begin;
  79     $begin->dispatch( $c );
  80     return !@{ $c->error };
  81 }
  82
  83 sub _AUTO : Private {
  84     my ( $self, $c ) = @_;
  85     my @auto = $c->get_actions( 'auto', $c->namespace );
  86     foreach my $auto (@auto) {
  87         $auto->dispatch( $c );
  88         return 0 unless $c->state;
  89     }
  90     return 1;
  91 }
  92
  93 sub _ACTION : Private {
  94     my ( $self, $c ) = @_;
  95     if (   ref $c->action
  96         && $c->action->can('execute')
  97         && $c->req->action )
  98     {
  99         $c->action->dispatch( $c );
 100     }
 101     return !@{ $c->error };
 102 }
 103
 104 sub _END : Private {
 105     my ( $self, $c ) = @_;
 106     my $end = ( $c->get_actions( 'end', $c->namespace ) )[-1];
 107     return 1 unless $end;
 108     $end->dispatch( $c );
 109     return !@{ $c->error };
 110 }
 111
 112 around new => sub {
 113     my $orig = shift;
 114     my $self = shift;
 115     my $app = $_[0];
 116     my $new = $self->$orig(@_);
 117     $new->_application( $app );
 118     return $new;
 119 };
 120
 121
 122 sub action_for {
 123     my ( $self, $name ) = @_;
 124     my $app = ($self->isa('Catalyst') ? $self : $self->_application);
 125     return $app->dispatcher->get_action($name, $self->action_namespace);
 126 }
 127
 128 sub action_namespace {
 129     my ( $self, $c ) = @_;
 130     unless ( $c ) {
 131         $c = ($self->isa('Catalyst') ? $self : $self->_application);
 132     }
 133     if( ref($self) ){
 134       return $self->_namespace if $self->_has_namespace;
 135     } # else {
 136       return $self->config->{namespace} if exists $self->config->{namespace};
 137     #}
 138     return Catalyst::Utils::class2prefix( ref($self) || $self,
 139         $c->config->{case_sensitive} )
 140       || '';
 141 }
 142
 143 sub path_prefix {
 144     my ( $self, $c ) = @_;
 145     unless ( $c ) {
 146         $c = ($self->isa('Catalyst') ? $self : $self->_application);
 147     }
 148     if( ref($self) ){
 149       return $self->path if $self->has_path;
 150     } # else {
 151       return $self->config->{path} if exists $self->config->{path};
 152     #}
 153     return shift->action_namespace(@_);
 154 }
 155
 156
 157 sub register_actions {
 158     my ( $self, $c ) = @_;
 159     my $class = ref $self || $self;
 160     #this is still not correct for some reason.
 161     my $namespace = $self->action_namespace($c);
 162     my %methods;
 163     if( $self->can('meta') ){
 164       my $meta = $self->meta;
 165       %methods = map{ $_->{code}->body => $_->{name} }
 166         grep {$_->{class} ne 'Moose::Object'}
 167           $meta->compute_all_applicable_methods;
 168     } else { #until we are sure there's no moose stuff left...
 169       $methods{ $self->can($_) } = $_
 170         for @{ Class::Inspector->methods($class) || [] };
 171     }
 172
 173     # Advanced inheritance support for plugins and the like
 174     #to be modified to use meta->superclasses
 175     my @action_cache;
 176     {
 177         no strict 'refs';
 178         for my $isa ( @{"$class\::ISA"}, $class ) {
 179             push @action_cache, @{ $isa->_action_cache }
 180               if $isa->can('_action_cache');
 181         }
 182     }
 183
 184     foreach my $cache (@action_cache) {
 185         my $code   = $cache->[0];
 186         my $method = delete $methods{$code}; # avoid dupe registers
 187         next unless $method;
 188         my $attrs = $self->_parse_attrs( $c, $method, @{ $cache->[1] } );
 189         if ( $attrs->{Private} && ( keys %$attrs > 1 ) ) {
 190             $c->log->debug( 'Bad action definition "'
 191                   . join( ' ', @{ $cache->[1] } )
 192                   . qq/" for "$class->$method"/ )
 193               if $c->debug;
 194             next;
 195         }
 196         my $reverse = $namespace ? "${namespace}/${method}" : $method;
 197         my $action = $self->create_action(
 198             name       => $method,
 199             code       => $code,
 200             reverse    => $reverse,
 201             namespace  => $namespace,
 202             class      => $class,
 203             attributes => $attrs,
 204         );
 205
 206         $c->dispatcher->register( $c, $action );
 207     }
 208 }
 209
 210 sub create_action {
 211     my $self = shift;
 212     my %args = @_;
 213
 214     my $class = (exists $args{attributes}{ActionClass}
 215                     ? $args{attributes}{ActionClass}[0]
 216                     : $self->_action_class);
 217
 218     unless ( Class::Inspector->loaded($class) ) {
 219         require Class::Inspector->filename($class);
 220     }
 221
 222     return $class->new( \%args );
 223 }
 224
 225 sub _parse_attrs {
 226     my ( $self, $c, $name, @attrs ) = @_;
 227
 228     my %raw_attributes;
 229
 230     foreach my $attr (@attrs) {
 231
 232         # Parse out :Foo(bar) into Foo => bar etc (and arrayify)
 233
 234         if ( my ( $key, $value ) = ( $attr =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ ) )
 235         {
 236
 237             if ( defined $value ) {
 238                 ( $value =~ s/^'(.*)'$/$1/ ) || ( $value =~ s/^"(.*)"/$1/ );
 239             }
 240             push( @{ $raw_attributes{$key} }, $value );
 241         }
 242     }
 243
 244     #this will not work under moose
 245     #my $hash = (ref $self ? $self : $self->config); # hate app-is-class
 246     my $hash = $self->config;
 247
 248     if (exists $hash->{actions} || exists $hash->{action}) {
 249       my $a = $hash->{actions} || $hash->{action};
 250       %raw_attributes = ((exists $a->{'*'} ? %{$a->{'*'}} : ()),
 251                          %raw_attributes,
 252                          (exists $a->{$name} ? %{$a->{$name}} : ()));
 253     }
 254
 255     my %final_attributes;
 256
 257     foreach my $key (keys %raw_attributes) {
 258
 259         my $raw = $raw_attributes{$key};
 260
 261         foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) {
 262
 263             my $meth = "_parse_${key}_attr";
 264             if ( $self->can($meth) ) {
 265                 ( $key, $value ) = $self->$meth( $c, $name, $value );
 266             }
 267             push( @{ $final_attributes{$key} }, $value );
 268         }
 269     }
 270
 271     return \%final_attributes;
 272 }
 273
 274 sub _parse_Global_attr {
 275     my ( $self, $c, $name, $value ) = @_;
 276     return $self->_parse_Path_attr( $c, $name, "/$name" );
 277 }
 278
 279 sub _parse_Absolute_attr { shift->_parse_Global_attr(@_); }
 280
 281 sub _parse_Local_attr {
 282     my ( $self, $c, $name, $value ) = @_;
 283     return $self->_parse_Path_attr( $c, $name, $name );
 284 }
 285
 286 sub _parse_Relative_attr { shift->_parse_Local_attr(@_); }
 287
 288 sub _parse_Path_attr {
 289     my ( $self, $c, $name, $value ) = @_;
 290     $value ||= '';
 291     if ( $value =~ m!^/! ) {
 292         return ( 'Path', $value );
 293     }
 294     elsif ( length $value ) {
 295         return ( 'Path', join( '/', $self->path_prefix($c), $value ) );
 296     }
 297     else {
 298         return ( 'Path', $self->path_prefix($c) );
 299     }
 300 }
 301
 302 sub _parse_Regex_attr {
 303     my ( $self, $c, $name, $value ) = @_;
 304     return ( 'Regex', $value );
 305 }
 306
 307 sub _parse_Regexp_attr { shift->_parse_Regex_attr(@_); }
 308
 309 sub _parse_LocalRegex_attr {
 310     my ( $self, $c, $name, $value ) = @_;
 311     unless ( $value =~ s/^\^// ) { $value = "(?:.*?)$value"; }
 312     return ( 'Regex', '^' . $self->path_prefix($c) . "/${value}" );
 313 }
 314
 315 sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); }
 316
 317 sub _parse_ActionClass_attr {
 318     my ( $self, $c, $name, $value ) = @_;
 319     unless ( $value =~ s/^\+// ) {
 320       $value = join('::', $self->_action_class, $value );
 321     }
 322     return ( 'ActionClass', $value );
 323 }
 324
 325 sub _parse_MyAction_attr {
 326     my ( $self, $c, $name, $value ) = @_;
 327
 328     my $appclass = Catalyst::Utils::class2appclass($self);
 329     $value = "${appclass}::Action::${value}";
 330
 331     return ( 'ActionClass', $value );
 332 }
 333
 334 1;
 335
 336 __END__
 337
 338 =head1 CONFIGURATION
 339
 340 Like any other L<Catalyst::Component>, controllers have a config hash,
 341 accessible through $self->config from the controller actions.  Some
 342 settings are in use by the Catalyst framework:
 343
 344 =head2 namespace
 345
 346 This specifies the internal namespace the controller should be bound
 347 to. By default the controller is bound to the URI version of the
 348 controller name. For instance controller 'MyApp::Controller::Foo::Bar'
 349 will be bound to 'foo/bar'. The default Root controller is an example
 350 of setting namespace to '' (the null string).
 351
 352 =head2 path
 353
 354 Sets 'path_prefix', as described below.
 355
 356 =head1 METHODS
 357
 358 =head2 $class->new($app, @args)
 359
 360 Proxies through to NEXT::new and stashes the application instance as
 361 $self->_application.
 362
 363 =head2 $self->action_for('name')
 364
 365 Returns the Catalyst::Action object (if any) for a given method name
 366 in this component.
 367
 368 =head2 $self->register_actions($c)
 369
 370 Finds all applicable actions for this component, creates
 371 Catalyst::Action objects (using $self->create_action) for them and
 372 registers them with $c->dispatcher.
 373
 374 =head2 $self->action_namespace($c)
 375
 376 Returns the private namespace for actions in this component. Defaults
 377 to a value from the controller name (for
 378 e.g. MyApp::Controller::Foo::Bar becomes "foo/bar") or can be
 379 overridden from the "namespace" config key.
 380
 381
 382 =head2 $self->path_prefix($c)
 383
 384 Returns the default path prefix for :Local, :LocalRegex and relative
 385 :Path actions in this component. Defaults to the action_namespace or
 386 can be overridden from the "path" config key.
 387
 388 =head2 $self->create_action(%args)
 389
 390 Called with a hash of data to be use for construction of a new
 391 Catalyst::Action (or appropriate sub/alternative class) object.
 392
 393 Primarily designed for the use of register_actions.
 394
 395 =head2 $self->_application
 396
 397 =head2 $self->_app
 398
 399 Returns the application instance stored by C<new()>
 400
 401 =head1 AUTHOR
 402
 403 Sebastian Riedel, C<sri@oook.de>
 404 Marcus Ramberg C<mramberg@cpan.org>
 405
 406 =head1 COPYRIGHT
 407
 408 This program is free software, you can redistribute it and/or modify
 409 it under the same terms as Perl itself.
 410
 411 =cut