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