lib/Catalyst/Controller.pm

   1 package Catalyst::Controller;
   2
   3 use base qw/Catalyst::Component Catalyst::AttrContainer/;
   4 use Moose;
   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 __PACKAGE__->mk_accessors( qw/_application/ );
  25
  26 has _application => (is => 'rw');
  27 sub _app{ shift->_application(@_) } # eww
  28
  29 use Scalar::Util qw/blessed/;
  30 use Catalyst::Exception;
  31 use Catalyst::Utils;
  32 use Class::Inspector;
  33
  34 =head1 NAME
  35
  36 Catalyst::Controller - Catalyst Controller base class
  37
  38 =head1 SYNOPSIS
  39
  40   package MyApp::Controller::Search
  41   use base qw/Catalyst::Controller/;
  42
  43   sub foo : Local {
  44     my ($self,$c,@args) = @_;
  45     ...
  46   } # Dispatches to /search/foo
  47
  48 =head1 DESCRIPTION
  49
  50 Controllers are where the actions in the Catalyst framework
  51 reside. Each action is represented by a function with an attribute to
  52 identify what kind of action it is. See the L<Catalyst::Dispatcher>
  53 for more info about how Catalyst dispatches to actions.
  54
  55 =cut
  56
  57 #I think both of these could be attributes. doesn't really seem like they need
  58 #to ble class data. i think that attributes +default would work just fine
  59 __PACKAGE__->mk_classdata($_) for qw/_dispatch_steps _action_class/;
  60
  61 __PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] );
  62 __PACKAGE__->_action_class('Catalyst::Action');
  63
  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 { #i think this is hacky and it should work with the else enabled
 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'} #ignore Moose::Object methods
 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     Class::MOP::load_class($class);
 219     #unless ( Class::Inspector->loaded($class) ) {
 220     #    require Class::Inspector->filename($class);
 221     #}
 222
 223     return $class->new( \%args );
 224 }
 225
 226 sub _parse_attrs {
 227     my ( $self, $c, $name, @attrs ) = @_;
 228
 229     my %raw_attributes;
 230
 231     foreach my $attr (@attrs) {
 232
 233         # Parse out :Foo(bar) into Foo => bar etc (and arrayify)
 234
 235         if ( my ( $key, $value ) = ( $attr =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ ) )
 236         {
 237
 238             if ( defined $value ) {
 239                 ( $value =~ s/^'(.*)'$/$1/ ) || ( $value =~ s/^"(.*)"/$1/ );
 240             }
 241             push( @{ $raw_attributes{$key} }, $value );
 242         }
 243     }
 244
 245     #this will not work under moose
 246     #my $hash = (ref $self ? $self : $self->config); # hate app-is-class
 247     #action / actions should be an attribute  of Controller
 248     my $hash = $self->config;
 249
 250     if (exists $hash->{actions} || exists $hash->{action}) {
 251       my $a = $hash->{actions} || $hash->{action};
 252       %raw_attributes = ((exists $a->{'*'} ? %{$a->{'*'}} : ()),
 253                          %raw_attributes,
 254                          (exists $a->{$name} ? %{$a->{$name}} : ()));
 255     }
 256
 257     my %final_attributes;
 258
 259     foreach my $key (keys %raw_attributes) {
 260
 261         my $raw = $raw_attributes{$key};
 262
 263         foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) {
 264
 265             my $meth = "_parse_${key}_attr";
 266             if ( $self->can($meth) ) {
 267                 ( $key, $value ) = $self->$meth( $c, $name, $value );
 268             }
 269             push( @{ $final_attributes{$key} }, $value );
 270         }
 271     }
 272
 273     return \%final_attributes;
 274 }
 275
 276 sub _parse_Global_attr {
 277     my ( $self, $c, $name, $value ) = @_;
 278     return $self->_parse_Path_attr( $c, $name, "/$name" );
 279 }
 280
 281 sub _parse_Absolute_attr { shift->_parse_Global_attr(@_); }
 282
 283 sub _parse_Local_attr {
 284     my ( $self, $c, $name, $value ) = @_;
 285     return $self->_parse_Path_attr( $c, $name, $name );
 286 }
 287
 288 sub _parse_Relative_attr { shift->_parse_Local_attr(@_); }
 289
 290 sub _parse_Path_attr {
 291     my ( $self, $c, $name, $value ) = @_;
 292     $value ||= '';
 293     if ( $value =~ m!^/! ) {
 294         return ( 'Path', $value );
 295     }
 296     elsif ( length $value ) {
 297         return ( 'Path', join( '/', $self->path_prefix($c), $value ) );
 298     }
 299     else {
 300         return ( 'Path', $self->path_prefix($c) );
 301     }
 302 }
 303
 304 sub _parse_Regex_attr {
 305     my ( $self, $c, $name, $value ) = @_;
 306     return ( 'Regex', $value );
 307 }
 308
 309 sub _parse_Regexp_attr { shift->_parse_Regex_attr(@_); }
 310
 311 sub _parse_LocalRegex_attr {
 312     my ( $self, $c, $name, $value ) = @_;
 313     unless ( $value =~ s/^\^// ) { $value = "(?:.*?)$value"; }
 314     return ( 'Regex', '^' . $self->path_prefix($c) . "/${value}" );
 315 }
 316
 317 sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); }
 318
 319 sub _parse_ActionClass_attr {
 320     my ( $self, $c, $name, $value ) = @_;
 321     unless ( $value =~ s/^\+// ) {
 322       $value = join('::', $self->_action_class, $value );
 323     }
 324     return ( 'ActionClass', $value );
 325 }
 326
 327 sub _parse_MyAction_attr {
 328     my ( $self, $c, $name, $value ) = @_;
 329
 330     my $appclass = Catalyst::Utils::class2appclass($self);
 331     $value = "${appclass}::Action::${value}";
 332
 333     return ( 'ActionClass', $value );
 334 }
 335
 336 1;
 337
 338 __END__
 339
 340 =head1 CONFIGURATION
 341
 342 Like any other L<Catalyst::Component>, controllers have a config hash,
 343 accessible through $self->config from the controller actions.  Some
 344 settings are in use by the Catalyst framework:
 345
 346 =head2 namespace
 347
 348 This specifies the internal namespace the controller should be bound
 349 to. By default the controller is bound to the URI version of the
 350 controller name. For instance controller 'MyApp::Controller::Foo::Bar'
 351 will be bound to 'foo/bar'. The default Root controller is an example
 352 of setting namespace to '' (the null string).
 353
 354 =head2 path
 355
 356 Sets 'path_prefix', as described below.
 357
 358 =head1 METHODS
 359
 360 =head2 $class->new($app, @args)
 361
 362 Proxies through to NEXT::new and stashes the application instance as
 363 $self->_application.
 364
 365 =head2 $self->action_for('name')
 366
 367 Returns the Catalyst::Action object (if any) for a given method name
 368 in this component.
 369
 370 =head2 $self->register_actions($c)
 371
 372 Finds all applicable actions for this component, creates
 373 Catalyst::Action objects (using $self->create_action) for them and
 374 registers them with $c->dispatcher.
 375
 376 =head2 $self->action_namespace($c)
 377
 378 Returns the private namespace for actions in this component. Defaults
 379 to a value from the controller name (for
 380 e.g. MyApp::Controller::Foo::Bar becomes "foo/bar") or can be
 381 overridden from the "namespace" config key.
 382
 383
 384 =head2 $self->path_prefix($c)
 385
 386 Returns the default path prefix for :Local, :LocalRegex and relative
 387 :Path actions in this component. Defaults to the action_namespace or
 388 can be overridden from the "path" config key.
 389
 390 =head2 $self->create_action(%args)
 391
 392 Called with a hash of data to be use for construction of a new
 393 Catalyst::Action (or appropriate sub/alternative class) object.
 394
 395 Primarily designed for the use of register_actions.
 396
 397 =head2 $self->_application
 398
 399 =head2 $self->_app
 400
 401 Returns the application instance stored by C<new()>
 402
 403 =head1 AUTHOR
 404
 405 Sebastian Riedel, C<sri@oook.de>
 406 Marcus Ramberg C<mramberg@cpan.org>
 407
 408 =head1 COPYRIGHT
 409
 410 This program is free software, you can redistribute it and/or modify
 411 it under the same terms as Perl itself.
 412
 413 =cut