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             $c->req->action($path);
 224             $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 225
 226             $c->req->match($path);
 227             $c->action($result->[0]);
 228             $c->namespace($result->[0]->prefix);
 229             last DESCEND;
 230         }
 231
 232         unless ( $c->action ) {
 233             foreach my $type (@{$self->dispatch_types}) {
 234                 last DESCEND if $type->prepare_action($c, $path);
 235                 #last DESCEND if $c->action;
 236             }
 237         }
 238
 239         unshift @args, pop @path;
 240     }
 241
 242     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 243       if ( $c->debug && @args );
 244 }
 245
 246 =item $self->get_action( $c, $action, $namespace, $inherit )
 247
 248 =cut
 249
 250 sub get_action {
 251     my ( $self, $c, $action, $namespace, $inherit ) = @_;
 252     return [] unless $action;
 253     $namespace ||= '';
 254     $inherit   ||= 0;
 255
 256     if ($namespace) {
 257
 258         my @match = $self->get_containers( $namespace );
 259
 260         my @results;
 261
 262         foreach my $child ($inherit ? @match: $match[-1]) {
 263             my $node = $child->actions;
 264             push(@results, [ $node->{$action} ]) if defined $node->{$action};
 265         }
 266         return \@results;
 267     }
 268
 269     elsif ( my $p = $self->actions->{plain}->{$action} ) { return [ [$p] ] }
 270
 271     return [];
 272 }
 273
 274 =item $self->get_containers( $namespace )
 275
 276 =cut
 277
 278 sub get_containers {
 279     my ( $self, $namespace ) = @_;
 280
 281     # If the namespace is / just return the root ActionContainer
 282
 283     return ($self->tree->getNodeValue) if $namespace eq '/';
 284
 285     # Use a visitor to recurse down the tree finding the ActionContainers
 286     # for each namespace in the chain.
 287
 288     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 289     my @path = split('/', $namespace);
 290     $visitor->setSearchPath( @path );
 291     $self->tree->accept($visitor);
 292
 293     my @match = $visitor->getResults;
 294     @match = ($self->tree) unless @match;
 295
 296     if (!defined $visitor->getResult) {
 297
 298         # If we don't manage to match, the visitor doesn't return the last
 299         # node is matched, so foo/bar/baz would only find the 'foo' node,
 300         # not the foo and foo/bar nodes as it should. This does another
 301         # single-level search to see if that's the case, and the 'last unless'
 302         # should catch any failures - or short-circuit this if this *is* a
 303         # bug in the visitor and gets fixed.
 304
 305         my $extra = $path[(scalar @match) - 1];
 306         last unless $extra;
 307         $visitor->setSearchPath($extra);
 308         $match[-1]->accept($visitor);
 309         push(@match, $visitor->getResult) if defined $visitor->getResult;
 310     }
 311
 312     return map { $_->getNodeValue } @match;
 313 }
 314
 315 =item $self->set_action( $c, $action, $code, $namespace, $attrs )
 316
 317 =cut
 318
 319 sub set_action {
 320     my ( $self, $c, $method, $code, $namespace, $attrs ) = @_;
 321
 322     my $prefix =
 323       Catalyst::Utils::class2prefix( $namespace, $c->config->{case_sensitive} )
 324       || '';
 325     my %flags;
 326     my %attributes;
 327
 328     for my $attr ( @{$attrs} ) {
 329         if    ( $attr =~ /^(Local|Relative)$/ )    { $flags{local}++ }
 330         elsif ( $attr =~ /^(Global|Absolute)$/ )   { $flags{global}++ }
 331         elsif ( $attr =~ /^Path\(\s*(.+)\s*\)$/i ) {
 332             push @{ $flags{path} }, $1;
 333         }
 334         elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
 335         elsif ( $attr =~ /^(Regex|Regexp)\(\s*(.+)\s*\)$/i ) {
 336             push @{ $flags{regex} }, $2;
 337         }
 338         if ( my ($key, $value) = ($attr =~ /^(.*?)(?:\(\s*(.+)\s*\))?$/) ) {
 339             if ( defined $value ) {
 340                 ($value =~ s/^'(.*)'$/$1/) || ($value =~ s/^"(.*)"/$1/);
 341             }
 342             push(@{$attributes{$key}}, $value);
 343         }
 344     }
 345
 346     if ( $flags{private} && ( keys %flags > 1 ) ) {
 347         $c->log->debug( 'Bad action definition "'
 348               . join( ' ', @{$attrs} )
 349               . qq/" for "$namespace->$method"/ )
 350           if $c->debug;
 351         return;
 352     }
 353     return unless keys %flags;
 354
 355     my $parent  = $self->tree;
 356     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 357
 358     if ($prefix) {
 359         for my $part ( split '/', $prefix ) {
 360             $visitor->setSearchPath($part);
 361             $parent->accept($visitor);
 362             my $child = $visitor->getResult;
 363
 364             unless ($child) {
 365
 366                 # Create a new tree node and an ActionContainer to form
 367                 # its value.
 368
 369                 my $container = Catalyst::ActionContainer->new(
 370                                     { part => $part, actions => {} });
 371                 $child = $parent->addChild( Tree::Simple->new($container) );
 372                 $visitor->setSearchPath($part);
 373                 $parent->accept($visitor);
 374                 $child = $visitor->getResult;
 375             }
 376
 377             $parent = $child;
 378         }
 379     }
 380
 381     my $reverse = $prefix ? "$prefix/$method" : $method;
 382
 383     my $action = Catalyst::Action->new(
 384         {
 385             code       => $code,
 386             reverse    => $reverse,
 387             namespace  => $namespace,
 388             prefix     => $prefix,
 389             attributes => \%attributes,
 390         }
 391     );
 392
 393     # Set the method value
 394     $parent->getNodeValue->actions->{$method} = $action;
 395
 396     my @path;
 397     for my $path ( @{ $flags{path} } ) {
 398         $path =~ s/^\w+//;
 399         $path =~ s/\w+$//;
 400         if ( $path =~ /^\s*'(.*)'\s*$/ ) { $path = $1 }
 401         if ( $path =~ /^\s*"(.*)"\s*$/ ) { $path = $1 }
 402         push @path, $path;
 403     }
 404     $flags{path} = \@path;
 405
 406     if ( $flags{local} || $flags{global} ) {
 407         push( @{ $flags{path} }, $prefix ? "/$prefix/$method" : "/$method" )
 408           if $flags{local};
 409
 410         push( @{ $flags{path} }, "/$method" ) if $flags{global};
 411     }
 412
 413     for my $path ( @{ $flags{path} } ) {
 414         if ( $path =~ /^\// ) { $path =~ s/^\/// }
 415         else { $path = $prefix ? "$prefix/$path" : $path }
 416         $self->actions->{plain}->{$path} = $action;
 417     }
 418
 419     foreach my $type ( @{ $self->dispatch_types } ) {
 420         $type->register_action($c, $action);
 421     }
 422 }
 423
 424 =item $self->setup_actions( $class, $component )
 425
 426 =cut
 427
 428 sub setup_actions {
 429     my ( $self, $class ) = @_;
 430
 431     # These are the core structures
 432     $self->actions(
 433         {
 434             plain    => {},
 435             private  => {},
 436             regex    => {},
 437             compiled => []
 438         }
 439     );
 440
 441     $self->dispatch_types([
 442         map { "Catalyst::DispatchType::$_"->new }
 443             qw/Regex Default/ ]);
 444
 445     # We use a tree
 446     my $container = Catalyst::ActionContainer->new(
 447                         { part => '/', actions => {} } );
 448     $self->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
 449
 450     for my $comp ( keys %{ $class->components } ) {
 451
 452         # We only setup components that inherit from Catalyst::Base
 453         next unless $comp->isa('Catalyst::Base');
 454
 455         for my $action ( @{ Catalyst::Utils::reflect_actions($comp) } ) {
 456             my ( $code, $attrs ) = @{$action};
 457             my $name = '';
 458             no strict 'refs';
 459             my @cache = ( $comp, @{"$comp\::ISA"} );
 460             my %namespaces;
 461
 462             while ( my $namespace = shift @cache ) {
 463                 $namespaces{$namespace}++;
 464                 for my $isa ( @{"$comp\::ISA"} ) {
 465                     next if $namespaces{$isa};
 466                     push @cache, $isa;
 467                     $namespaces{$isa}++;
 468                 }
 469             }
 470
 471             for my $namespace ( keys %namespaces ) {
 472
 473                 for my $sym ( values %{ $namespace . '::' } ) {
 474
 475                     if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
 476
 477                         $name = *{$sym}{NAME};
 478                         $class->set_action( $name, $code, $comp, $attrs );
 479                         last;
 480                     }
 481
 482                 }
 483
 484             }
 485
 486         }
 487
 488     }
 489
 490     return unless $class->debug;
 491
 492     my $actions  = $self->actions;
 493     my $privates = Text::ASCIITable->new;
 494     $privates->setCols( 'Private', 'Class' );
 495     $privates->setColWidth( 'Private', 36, 1 );
 496     $privates->setColWidth( 'Class',   37, 1 );
 497
 498     my $walker = sub {
 499         my ( $walker, $parent, $prefix ) = @_;
 500         $prefix .= $parent->getNodeValue || '';
 501         $prefix .= '/' unless $prefix =~ /\/$/;
 502         my $node = $parent->getNodeValue->actions;
 503
 504         for my $action ( keys %{ $node } ) {
 505             my $action_obj = $node->{$action};
 506             $privates->addRow( "$prefix$action", $action_obj->namespace );
 507         }
 508
 509         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 510     };
 511
 512     $walker->( $walker, $self->tree, '' );
 513     $class->log->debug( "Loaded private actions:\n" . $privates->draw )
 514       if ( @{ $privates->{tbl_rows} } );
 515
 516     my $publics = Text::ASCIITable->new;
 517     $publics->setCols( 'Public', 'Private' );
 518     $publics->setColWidth( 'Public',  36, 1 );
 519     $publics->setColWidth( 'Private', 37, 1 );
 520
 521     for my $plain ( sort keys %{ $actions->{plain} } ) {
 522         my $action = $actions->{plain}->{$plain};
 523         $publics->addRow( "/$plain", "/$action" );
 524     }
 525
 526     $class->log->debug( "Loaded public actions:\n" . $publics->draw )
 527       if ( @{ $publics->{tbl_rows} } );
 528
 529     my $regexes = Text::ASCIITable->new;
 530     $regexes->setCols( 'Regex', 'Private' );
 531     $regexes->setColWidth( 'Regex',   36, 1 );
 532     $regexes->setColWidth( 'Private', 37, 1 );
 533
 534     for my $regex ( sort keys %{ $actions->{regex} } ) {
 535         my $action = $actions->{regex}->{$regex};
 536         $regexes->addRow( $regex, "/$action" );
 537     }
 538
 539     $class->log->debug( "Loaded regex actions:\n" . $regexes->draw )
 540       if ( @{ $regexes->{tbl_rows} } );
 541 }
 542
 543 =back
 544
 545 =head1 AUTHOR
 546
 547 Sebastian Riedel, C<sri@cpan.org>
 548
 549 =head1 COPYRIGHT
 550
 551 This program is free software, you can redistribute it and/or modify it under
 552 the same terms as Perl itself.
 553
 554 =cut
 555
 556 1;