lib/Catalyst/Controller.pm

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