lib/Catalyst/Dispatcher.pm

   1 package Catalyst::Dispatcher;
   2
   3 use strict;
   4 use base 'Class::Accessor::Fast';
   5 use Catalyst::Exception;
   6 use Catalyst::Utils;
   7 use Catalyst::Action;
   8 use Catalyst::ActionContainer;
   9 use Text::ASCIITable;
  10 use Tree::Simple;
  11 use Tree::Simple::Visitor::FindByPath;
  12
  13 # Stringify to class
  14 use overload '""' => sub { return ref shift }, fallback => 1;
  15
  16 __PACKAGE__->mk_accessors(qw/actions tree/);
  17
  18 =head1 NAME
  19
  20 Catalyst::Dispatcher - The Catalyst Dispatcher
  21
  22 =head1 SYNOPSIS
  23
  24 See L<Catalyst>.
  25
  26 =head1 DESCRIPTION
  27
  28 =head1 METHODS
  29
  30 =over 4
  31
  32 =item $self->detach( $c, $command [, \@arguments ] )
  33
  34 =cut
  35
  36 sub detach {
  37     my ( $self, $c, $command, @args ) = @_;
  38     $c->forward( $command, @args ) if $command;
  39     die $Catalyst::DETACH;
  40 }
  41
  42 =item $self->dispatch($c)
  43
  44 =cut
  45
  46 sub dispatch {
  47     my ( $self, $c ) = @_;
  48     my $action    = $c->req->action;
  49     my $namespace = '';
  50     $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
  51       if $action eq 'default';
  52
  53     unless ($namespace) {
  54         if ( my $result = $c->get_action($action) ) {
  55             $namespace = $result->[0]->[0]->prefix;
  56         }
  57     }
  58
  59     my $default = $action eq 'default' ? $namespace : undef;
  60     my $results = $c->get_action( $action, $default, $default ? 1 : 0 );
  61     $namespace ||= '/';
  62
  63     my @containers = $self->get_containers( $namespace );
  64     my %actions;
  65     foreach my $name (qw/begin auto end/) {
  66         $actions{$name} = [
  67             map { $_->{$name} }
  68             grep { exists $_->{$name} }
  69             map { $_->actions }
  70             @containers
  71         ];
  72     }
  73
  74     if ( @{$results} ) {
  75
  76         # Errors break the normal flow and the end action is instantly run
  77         my $error = 0;
  78
  79         # Execute last begin
  80         $c->state(1);
  81         if ( my $begin = @{ $actions{begin}  }[-1] ) {
  82             $begin->execute($c);
  83             $error++ if scalar @{ $c->error };
  84         }
  85
  86         # Execute the auto chain
  87         my $autorun = 0;
  88         for my $auto ( @{ $actions{auto} } ) {
  89             last if $error;
  90             $autorun++;
  91             $auto->execute($c);
  92             $error++ if scalar @{ $c->error };
  93             last unless $c->state;
  94         }
  95
  96         # Execute the action or last default
  97         my $mkay = $autorun ? $c->state ? 1 : 0 : 1;
  98         if ( ( my $action = $c->req->action ) && $mkay ) {
  99             unless ($error) {
 100                 if ( my $result =
 101                     @{ $c->get_action( $action, $default, 1 ) }[-1] )
 102                 {
 103                     $result->[0]->execute($c);
 104                     $error++ if scalar @{ $c->error };
 105                 }
 106             }
 107         }
 108
 109         # Execute last end
 110         if ( my $end = @{ $actions{end} }[-1] ) {
 111             $end->execute($c);
 112         }
 113     }
 114
 115     else {
 116         my $path  = $c->req->path;
 117         my $error = $path
 118           ? qq/Unknown resource "$path"/
 119           : "No default action defined";
 120         $c->log->error($error) if $c->debug;
 121         $c->error($error);
 122     }
 123 }
 124
 125 =item $self->forward( $c, $command [, \@arguments ] )
 126
 127 =cut
 128
 129 sub forward {
 130     my $self    = shift;
 131     my $c       = shift;
 132     my $command = shift;
 133
 134     unless ($command) {
 135         $c->log->debug('Nothing to forward to') if $c->debug;
 136         return 0;
 137     }
 138
 139     # Relative forwards from detach
 140     my $caller = ( caller(1) )[0]->isa('Catalyst::Dispatcher')
 141       && ( ( caller(2) )[3] =~ /::detach$/ ) ? caller(3) : caller(1);
 142
 143     my $arguments = ( ref( $_[-1] ) eq 'ARRAY' ) ? pop(@_) : $c->req->args;
 144
 145     my $results = [];
 146
 147     my $command_copy = $command;
 148
 149     unless ( $command_copy =~ s/^\/// ) {
 150         my $namespace =
 151           Catalyst::Utils::class2prefix( $caller, $c->config->{case_sensitive} ) || '';
 152         $command_copy = "${namespace}/${command}";
 153     }
 154
 155     unless ( $command_copy =~ /\// ) {
 156         $results = $c->get_action( $command_copy, '/' );
 157     }
 158     else {
 159         my @extra_args;
 160       DESCEND: while ( $command_copy =~ s/^(.*)\/(\w+)$/$1/ ) {
 161             my $tail = $2;
 162             $results = $c->get_action( $tail, $1 );
 163             if ( @{$results} ) {
 164                 $command = $tail;
 165                 push( @{$arguments}, @extra_args );
 166                 last DESCEND;
 167             }
 168             unshift( @extra_args, $tail );
 169         }
 170     }
 171
 172     unless ( @{$results} ) {
 173
 174         unless ( $c->components->{$command} ) {
 175             my $error =
 176 qq/Couldn't forward to command "$command". Invalid action or component./;
 177             $c->error($error);
 178             $c->log->debug($error) if $c->debug;
 179             return 0;
 180         }
 181
 182         my $class  = $command;
 183         my $method = shift || 'process';
 184
 185         if ( my $code = $c->components->{$class}->can($method) ) {
 186             my $action = Catalyst::Action->new(
 187                 {
 188                     code      => $code,
 189                     reverse   => "$class->$method",
 190                     namespace => $class,
 191                     prefix    => $class,
 192                 }
 193             );
 194             $results = [ [$action] ];
 195         }
 196
 197         else {
 198             my $error =
 199               qq/Couldn't forward to "$class". Does not implement "$method"/;
 200             $c->error($error);
 201             $c->log->debug($error)
 202               if $c->debug;
 203             return 0;
 204         }
 205
 206     }
 207
 208     local $c->request->{arguments} = [ @{$arguments} ];
 209
 210     for my $result ( @{$results} ) {
 211         $result->[0]->execute($c);
 212         return if scalar @{ $c->error };
 213         last unless $c->state;
 214     }
 215
 216     return $c->state;
 217 }
 218
 219 =item $self->prepare_action($c)
 220
 221 =cut
 222
 223 sub prepare_action {
 224     my ( $self, $c ) = @_;
 225     my $path = $c->req->path;
 226     my @path = split /\//, $c->req->path;
 227     $c->req->args( \my @args );
 228
 229     while (@path) {
 230         $path = join '/', @path;
 231         if ( my $result = ${ $c->get_action($path) }[0] ) {
 232
 233             # It's a regex
 234             if ($#$result) {
 235                 my $match    = $result->[1];
 236                 my @snippets = @{ $result->[2] };
 237                 $c->log->debug(
 238                     qq/Requested action is "$path" and matched "$match"/)
 239                   if $c->debug;
 240                 $c->log->debug(
 241                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 242                   if ( $c->debug && @snippets );
 243                 $c->req->action($match);
 244                 $c->req->snippets( \@snippets );
 245             }
 246
 247             else {
 248                 $c->req->action($path);
 249                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 250             }
 251
 252             $c->req->match($path);
 253             last;
 254         }
 255         unshift @args, pop @path;
 256     }
 257
 258     unless ( $c->req->action ) {
 259         $c->req->action('default');
 260         $c->req->match('');
 261     }
 262
 263     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 264       if ( $c->debug && @args );
 265 }
 266
 267 =item $self->get_action( $c, $action, $namespace, $inherit )
 268
 269 =cut
 270
 271 sub get_action {
 272     my ( $self, $c, $action, $namespace, $inherit ) = @_;
 273     return [] unless $action;
 274     $namespace ||= '';
 275     $inherit   ||= 0;
 276
 277     if ($namespace) {
 278
 279         my @match = $self->get_containers( $namespace );
 280
 281         my @results;
 282
 283         foreach my $child ($inherit ? @match: $match[-1]) {
 284             my $node = $child->actions;
 285             push(@results, [ $node->{$action} ]) if defined $node->{$action};
 286         }
 287         return \@results;
 288     }
 289
 290     elsif ( my $p = $self->actions->{plain}->{$action} ) { return [ [$p] ] }
 291     elsif ( my $r = $self->actions->{regex}->{$action} ) { return [ [$r] ] }
 292
 293     else {
 294
 295         for my $i ( 0 .. $#{ $self->actions->{compiled} } ) {
 296             my $name  = $self->actions->{compiled}->[$i]->[0];
 297             my $regex = $self->actions->{compiled}->[$i]->[1];
 298
 299             if ( my @snippets = ( $action =~ $regex ) ) {
 300                 return [
 301                     [ $self->actions->{regex}->{$name}, $name, \@snippets ] ];
 302             }
 303
 304         }
 305     }
 306     return [];
 307 }
 308
 309 =item $self->get_containers( $namespace )
 310
 311 =cut
 312
 313 sub get_containers {
 314     my ( $self, $namespace ) = @_;
 315
 316     return ($self->tree->getNodeValue) if $namespace eq '/';
 317
 318     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 319     my @path = split('/', $namespace);
 320     $visitor->setSearchPath( @path );
 321     $self->tree->accept($visitor);
 322
 323     my @match = $visitor->getResults;
 324     @match = ($self->tree) unless @match;
 325
 326     if (!defined $visitor->getResult) {
 327         my $extra = $path[(scalar @match) - 1];
 328         last unless $extra;
 329         $visitor->setSearchPath($extra);
 330         $match[-1]->accept($visitor);
 331         push(@match, $visitor->getResult) if defined $visitor->getResult;
 332     }
 333
 334     return map { $_->getNodeValue } @match;
 335 }
 336
 337 =item $self->set_action( $c, $action, $code, $namespace, $attrs )
 338
 339 =cut
 340
 341 sub set_action {
 342     my ( $self, $c, $method, $code, $namespace, $attrs ) = @_;
 343
 344     my $prefix =
 345       Catalyst::Utils::class2prefix( $namespace, $c->config->{case_sensitive} )
 346       || '';
 347     my %flags;
 348
 349     for my $attr ( @{$attrs} ) {
 350         if    ( $attr =~ /^(Local|Relative)$/ )    { $flags{local}++ }
 351         elsif ( $attr =~ /^(Global|Absolute)$/ )   { $flags{global}++ }
 352         elsif ( $attr =~ /^Path\(\s*(.+)\s*\)$/i ) {
 353             push @{ $flags{path} }, $1;
 354         }
 355         elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
 356         elsif ( $attr =~ /^(Regex|Regexp)\(\s*(.+)\s*\)$/i ) {
 357             push @{ $flags{regex} }, $2;
 358         }
 359     }
 360
 361     if ( $flags{private} && ( keys %flags > 1 ) ) {
 362         $c->log->debug( 'Bad action definition "'
 363               . join( ' ', @{$attrs} )
 364               . qq/" for "$namespace->$method"/ )
 365           if $c->debug;
 366         return;
 367     }
 368     return unless keys %flags;
 369
 370     my $parent  = $self->tree;
 371     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 372
 373     if ($prefix) {
 374         for my $part ( split '/', $prefix ) {
 375             $visitor->setSearchPath($part);
 376             $parent->accept($visitor);
 377             my $child = $visitor->getResult;
 378
 379             unless ($child) {
 380                 my $container = Catalyst::ActionContainer->new(
 381                                     { part => $part, actions => {} });
 382                 $child = $parent->addChild( Tree::Simple->new($container) );
 383                 $visitor->setSearchPath($part);
 384                 $parent->accept($visitor);
 385                 $child = $visitor->getResult;
 386             }
 387
 388             $parent = $child;
 389         }
 390     }
 391
 392     my $reverse = $prefix ? "$prefix/$method" : $method;
 393
 394     my $action = Catalyst::Action->new(
 395         {
 396             code      => $code,
 397             reverse   => $reverse,
 398             namespace => $namespace,
 399             prefix    => $prefix,
 400         }
 401     );
 402
 403     $parent->getNodeValue->actions->{$method} = $action;
 404
 405     my @path;
 406     for my $path ( @{ $flags{path} } ) {
 407         $path =~ s/^\w+//;
 408         $path =~ s/\w+$//;
 409         if ( $path =~ /^\s*'(.*)'\s*$/ ) { $path = $1 }
 410         if ( $path =~ /^\s*"(.*)"\s*$/ ) { $path = $1 }
 411         push @path, $path;
 412     }
 413     $flags{path} = \@path;
 414
 415     my @regex;
 416     for my $regex ( @{ $flags{regex} } ) {
 417         $regex =~ s/^\w+//;
 418         $regex =~ s/\w+$//;
 419         if ( $regex =~ /^\s*'(.*)'\s*$/ ) { $regex = $1 }
 420         if ( $regex =~ /^\s*"(.*)"\s*$/ ) { $regex = $1 }
 421         push @regex, $regex;
 422     }
 423     $flags{regex} = \@regex;
 424
 425     if ( $flags{local} || $flags{global} ) {
 426         push( @{ $flags{path} }, $prefix ? "/$prefix/$method" : "/$method" )
 427           if $flags{local};
 428
 429         push( @{ $flags{path} }, "/$method" ) if $flags{global};
 430     }
 431
 432     for my $path ( @{ $flags{path} } ) {
 433         if ( $path =~ /^\// ) { $path =~ s/^\/// }
 434         else { $path = $prefix ? "$prefix/$path" : $path }
 435         $self->actions->{plain}->{$path} = $action;
 436     }
 437
 438     for my $regex ( @{ $flags{regex} } ) {
 439         push @{ $self->actions->{compiled} }, [ $regex, qr#$regex# ];
 440         $self->actions->{regex}->{$regex} = $action;
 441     }
 442 }
 443
 444 =item $self->setup_actions( $class, $component )
 445
 446 =cut
 447
 448 sub setup_actions {
 449     my ( $self, $class ) = @_;
 450
 451     # These are the core structures
 452     $self->actions(
 453         {
 454             plain    => {},
 455             private  => {},
 456             regex    => {},
 457             compiled => []
 458         }
 459     );
 460
 461     # We use a tree
 462     my $container = Catalyst::ActionContainer->new(
 463                         { part => '/', actions => {} } );
 464     $self->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
 465
 466     for my $comp ( keys %{ $class->components } ) {
 467
 468         # We only setup components that inherit from Catalyst::Base
 469         next unless $comp->isa('Catalyst::Base');
 470
 471         for my $action ( @{ Catalyst::Utils::reflect_actions($comp) } ) {
 472             my ( $code, $attrs ) = @{$action};
 473             my $name = '';
 474             no strict 'refs';
 475             my @cache = ( $comp, @{"$comp\::ISA"} );
 476             my %namespaces;
 477
 478             while ( my $namespace = shift @cache ) {
 479                 $namespaces{$namespace}++;
 480                 for my $isa ( @{"$comp\::ISA"} ) {
 481                     next if $namespaces{$isa};
 482                     push @cache, $isa;
 483                     $namespaces{$isa}++;
 484                 }
 485             }
 486
 487             for my $namespace ( keys %namespaces ) {
 488
 489                 for my $sym ( values %{ $namespace . '::' } ) {
 490
 491                     if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
 492
 493                         $name = *{$sym}{NAME};
 494                         $class->set_action( $name, $code, $comp, $attrs );
 495                         last;
 496                     }
 497
 498                 }
 499
 500             }
 501
 502         }
 503
 504     }
 505
 506     return unless $class->debug;
 507
 508     my $actions  = $self->actions;
 509     my $privates = Text::ASCIITable->new;
 510     $privates->setCols( 'Private', 'Class' );
 511     $privates->setColWidth( 'Private', 36, 1 );
 512     $privates->setColWidth( 'Class',   37, 1 );
 513
 514     my $walker = sub {
 515         my ( $walker, $parent, $prefix ) = @_;
 516         $prefix .= $parent->getNodeValue || '';
 517         $prefix .= '/' unless $prefix =~ /\/$/;
 518         my $node = $parent->getNodeValue->actions;
 519
 520         for my $action ( keys %{ $node } ) {
 521             my $action_obj = $node->{$action};
 522             $privates->addRow( "$prefix$action", $action_obj->namespace );
 523         }
 524
 525         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 526     };
 527
 528     $walker->( $walker, $self->tree, '' );
 529     $class->log->debug( "Loaded private actions:\n" . $privates->draw )
 530       if ( @{ $privates->{tbl_rows} } );
 531
 532     my $publics = Text::ASCIITable->new;
 533     $publics->setCols( 'Public', 'Private' );
 534     $publics->setColWidth( 'Public',  36, 1 );
 535     $publics->setColWidth( 'Private', 37, 1 );
 536
 537     for my $plain ( sort keys %{ $actions->{plain} } ) {
 538         my $action = $actions->{plain}->{$plain};
 539         $publics->addRow( "/$plain", "/$action" );
 540     }
 541
 542     $class->log->debug( "Loaded public actions:\n" . $publics->draw )
 543       if ( @{ $publics->{tbl_rows} } );
 544
 545     my $regexes = Text::ASCIITable->new;
 546     $regexes->setCols( 'Regex', 'Private' );
 547     $regexes->setColWidth( 'Regex',   36, 1 );
 548     $regexes->setColWidth( 'Private', 37, 1 );
 549
 550     for my $regex ( sort keys %{ $actions->{regex} } ) {
 551         my $action = $actions->{regex}->{$regex};
 552         $regexes->addRow( $regex, "/$action" );
 553     }
 554
 555     $class->log->debug( "Loaded regex actions:\n" . $regexes->draw )
 556       if ( @{ $regexes->{tbl_rows} } );
 557 }
 558
 559 =back
 560
 561 =head1 AUTHOR
 562
 563 Sebastian Riedel, C<sri@cpan.org>
 564
 565 =head1 COPYRIGHT
 566
 567 This program is free software, you can redistribute it and/or modify it under
 568 the same terms as Perl itself.
 569
 570 =cut
 571
 572 1;