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 Text::ASCIITable;
   9 use Tree::Simple;
  10 use Tree::Simple::Visitor::FindByPath;
  11
  12 # Stringify to class
  13 use overload '""' => sub { return ref shift }, fallback => 1;
  14
  15 __PACKAGE__->mk_accessors(qw/actions tree/);
  16
  17 =head1 NAME
  18
  19 Catalyst::Dispatcher - The Catalyst Dispatcher
  20
  21 =head1 SYNOPSIS
  22
  23 See L<Catalyst>.
  24
  25 =head1 DESCRIPTION
  26
  27 =head1 METHODS
  28
  29 =over 4
  30
  31 =item $self->detach( $c, $command [, \@arguments ] )
  32
  33 =cut
  34
  35 sub detach {
  36     my ( $self, $c, $command, @args ) = @_;
  37     $c->forward( $command, @args ) if $command;
  38     die $Catalyst::DETACH;
  39 }
  40
  41 =item $self->dispatch($c)
  42
  43 =cut
  44
  45 sub dispatch {
  46     my ( $self, $c ) = @_;
  47     my $action    = $c->req->action;
  48     my $namespace = '';
  49     $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
  50       if $action eq 'default';
  51
  52     unless ($namespace) {
  53         if ( my $result = $c->get_action($action) ) {
  54             $namespace =
  55               Catalyst::Utils::class2prefix( $result->[0]->[0]->namespace,
  56                 $c->config->{case_sensitive} );
  57         }
  58     }
  59
  60     my $default = $action eq 'default' ? $namespace : undef;
  61     my $results = $c->get_action( $action, $default, $default ? 1 : 0 );
  62     $namespace ||= '/';
  63
  64     if ( @{$results} ) {
  65
  66         # Errors break the normal flow and the end action is instantly run
  67         my $error = 0;
  68
  69         # Execute last begin
  70         $c->state(1);
  71         if ( my $begin = @{ $c->get_action( 'begin', $namespace, 1 ) }[-1] ) {
  72             $begin->[0]->execute($c);
  73             $error++ if scalar @{ $c->error };
  74         }
  75
  76         # Execute the auto chain
  77         my $autorun = 0;
  78         for my $auto ( @{ $c->get_action( 'auto', $namespace, 1 ) } ) {
  79             last if $error;
  80             $autorun++;
  81             $auto->[0]->execute($c);
  82             $error++ if scalar @{ $c->error };
  83             last unless $c->state;
  84         }
  85
  86         # Execute the action or last default
  87         my $mkay = $autorun ? $c->state ? 1 : 0 : 1;
  88         if ( ( my $action = $c->req->action ) && $mkay ) {
  89             unless ($error) {
  90                 if ( my $result =
  91                     @{ $c->get_action( $action, $default, 1 ) }[-1] )
  92                 {
  93                     $result->[0]->execute($c);
  94                     $error++ if scalar @{ $c->error };
  95                 }
  96             }
  97         }
  98
  99         # Execute last end
 100         if ( my $end = @{ $c->get_action( 'end', $namespace, 1 ) }[-1] ) {
 101             $end->[0]->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                 }
 182             );
 183             $results = [ [$action] ];
 184         }
 185
 186         else {
 187             my $error =
 188               qq/Couldn't forward to "$class". Does not implement "$method"/;
 189             $c->error($error);
 190             $c->log->debug($error)
 191               if $c->debug;
 192             return 0;
 193         }
 194
 195     }
 196
 197     local $c->request->{arguments} = [ @{$arguments} ];
 198
 199     for my $result ( @{$results} ) {
 200         $result->[0]->execute($c);
 201         return if scalar @{ $c->error };
 202         last unless $c->state;
 203     }
 204
 205     return $c->state;
 206 }
 207
 208 =item $self->prepare_action($c)
 209
 210 =cut
 211
 212 sub prepare_action {
 213     my ( $self, $c ) = @_;
 214     my $path = $c->req->path;
 215     my @path = split /\//, $c->req->path;
 216     $c->req->args( \my @args );
 217
 218     while (@path) {
 219         $path = join '/', @path;
 220         if ( my $result = ${ $c->get_action($path) }[0] ) {
 221
 222             # It's a regex
 223             if ($#$result) {
 224                 my $match    = $result->[1];
 225                 my @snippets = @{ $result->[2] };
 226                 $c->log->debug(
 227                     qq/Requested action is "$path" and matched "$match"/)
 228                   if $c->debug;
 229                 $c->log->debug(
 230                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 231                   if ( $c->debug && @snippets );
 232                 $c->req->action($match);
 233                 $c->req->snippets( \@snippets );
 234             }
 235
 236             else {
 237                 $c->req->action($path);
 238                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 239             }
 240
 241             $c->req->match($path);
 242             last;
 243         }
 244         unshift @args, pop @path;
 245     }
 246
 247     unless ( $c->req->action ) {
 248         $c->req->action('default');
 249         $c->req->match('');
 250     }
 251
 252     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 253       if ( $c->debug && @args );
 254 }
 255
 256 =item $self->get_action( $c, $action, $namespace, $inherit )
 257
 258 =cut
 259
 260 sub get_action {
 261     my ( $self, $c, $action, $namespace, $inherit ) = @_;
 262     return [] unless $action;
 263     $namespace ||= '';
 264     $inherit   ||= 0;
 265
 266     if ($namespace) {
 267
 268         my $parent = $self->tree;
 269         my @match;
 270
 271         if ($namespace ne '/') {
 272
 273             my $visitor = Tree::Simple::Visitor::FindByPath->new;
 274             my @path = split('/', $namespace);
 275             $visitor->setSearchPath( @path );
 276             $parent->accept($visitor);
 277
 278             if ($inherit) {
 279
 280                 @match = $visitor->getResults;
 281                 @match = ($parent) unless @match;
 282
 283                 if (!defined $visitor->getResult) {
 284                     my $extra = $path[(scalar @match) - 1];
 285                     last unless $extra;
 286                     $visitor->setSearchPath($extra);
 287                     $match[-1]->accept($visitor);
 288                     push(@match, $visitor->getResult) if defined $visitor->getResult;
 289                 }
 290             } else {
 291                 @match = ($visitor->getResult) if $visitor->getResult;
 292             }
 293
 294         }
 295
 296         @match = ($parent) unless @match;
 297
 298         my @results;
 299
 300         foreach my $child (@match) {
 301             my $node = $self->actions->{private}->{$child->getUID};
 302             next unless $node;
 303             push(@results, [ $node->{$action} ]) if defined $node->{$action};
 304         }
 305         return \@results;
 306     }
 307
 308     elsif ( my $p = $self->actions->{plain}->{$action} ) { return [ [$p] ] }
 309     elsif ( my $r = $self->actions->{regex}->{$action} ) { return [ [$r] ] }
 310
 311     else {
 312
 313         for my $i ( 0 .. $#{ $self->actions->{compiled} } ) {
 314             my $name  = $self->actions->{compiled}->[$i]->[0];
 315             my $regex = $self->actions->{compiled}->[$i]->[1];
 316
 317             if ( my @snippets = ( $action =~ $regex ) ) {
 318                 return [
 319                     [ $self->actions->{regex}->{$name}, $name, \@snippets ] ];
 320             }
 321
 322         }
 323     }
 324     return [];
 325 }
 326
 327 =item $self->set_action( $c, $action, $code, $namespace, $attrs )
 328
 329 =cut
 330
 331 sub set_action {
 332     my ( $self, $c, $method, $code, $namespace, $attrs ) = @_;
 333
 334     my $prefix =
 335       Catalyst::Utils::class2prefix( $namespace, $c->config->{case_sensitive} )
 336       || '';
 337     my %flags;
 338
 339     for my $attr ( @{$attrs} ) {
 340         if    ( $attr =~ /^(Local|Relative)$/ )    { $flags{local}++ }
 341         elsif ( $attr =~ /^(Global|Absolute)$/ )   { $flags{global}++ }
 342         elsif ( $attr =~ /^Path\(\s*(.+)\s*\)$/i ) {
 343             push @{ $flags{path} }, $1;
 344         }
 345         elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
 346         elsif ( $attr =~ /^(Regex|Regexp)\(\s*(.+)\s*\)$/i ) {
 347             push @{ $flags{regex} }, $2;
 348         }
 349     }
 350
 351     if ( $flags{private} && ( keys %flags > 1 ) ) {
 352         $c->log->debug( 'Bad action definition "'
 353               . join( ' ', @{$attrs} )
 354               . qq/" for "$namespace->$method"/ )
 355           if $c->debug;
 356         return;
 357     }
 358     return unless keys %flags;
 359
 360     my $parent  = $self->tree;
 361     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 362
 363     for my $part ( split '/', $prefix ) {
 364         $visitor->setSearchPath($part);
 365         $parent->accept($visitor);
 366         my $child = $visitor->getResult;
 367
 368         unless ($child) {
 369             $child = $parent->addChild( Tree::Simple->new($part) );
 370             $visitor->setSearchPath($part);
 371             $parent->accept($visitor);
 372             $child = $visitor->getResult;
 373         }
 374
 375         $parent = $child;
 376     }
 377
 378     my $reverse = $prefix ? "$prefix/$method" : $method;
 379
 380     my $action = Catalyst::Action->new(
 381         {
 382             code      => $code,
 383             reverse   => $reverse,
 384             namespace => $namespace,
 385         }
 386     );
 387
 388     my $uid = $parent->getUID;
 389     $self->actions->{private}->{$uid}->{$method} = $action;
 390
 391     my @path;
 392     for my $path ( @{ $flags{path} } ) {
 393         $path =~ s/^\w+//;
 394         $path =~ s/\w+$//;
 395         if ( $path =~ /^\s*'(.*)'\s*$/ ) { $path = $1 }
 396         if ( $path =~ /^\s*"(.*)"\s*$/ ) { $path = $1 }
 397         push @path, $path;
 398     }
 399     $flags{path} = \@path;
 400
 401     my @regex;
 402     for my $regex ( @{ $flags{regex} } ) {
 403         $regex =~ s/^\w+//;
 404         $regex =~ s/\w+$//;
 405         if ( $regex =~ /^\s*'(.*)'\s*$/ ) { $regex = $1 }
 406         if ( $regex =~ /^\s*"(.*)"\s*$/ ) { $regex = $1 }
 407         push @regex, $regex;
 408     }
 409     $flags{regex} = \@regex;
 410
 411     if ( $flags{local} || $flags{global} ) {
 412         push( @{ $flags{path} }, $prefix ? "/$prefix/$method" : "/$method" )
 413           if $flags{local};
 414
 415         push( @{ $flags{path} }, "/$method" ) if $flags{global};
 416     }
 417
 418     for my $path ( @{ $flags{path} } ) {
 419         if ( $path =~ /^\// ) { $path =~ s/^\/// }
 420         else { $path = $prefix ? "$prefix/$path" : $path }
 421         $self->actions->{plain}->{$path} = $action;
 422     }
 423
 424     for my $regex ( @{ $flags{regex} } ) {
 425         push @{ $self->actions->{compiled} }, [ $regex, qr#$regex# ];
 426         $self->actions->{regex}->{$regex} = $action;
 427     }
 428 }
 429
 430 =item $self->setup_actions( $class, $component )
 431
 432 =cut
 433
 434 sub setup_actions {
 435     my ( $self, $class ) = @_;
 436
 437     # These are the core structures
 438     $self->actions(
 439         {
 440             plain    => {},
 441             private  => {},
 442             regex    => {},
 443             compiled => []
 444         }
 445     );
 446
 447     # We use a tree
 448     $self->tree( Tree::Simple->new( 0, 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 $uid = $parent->getUID;
 503
 504         for my $action ( keys %{ $actions->{private}->{$uid} } ) {
 505             my $action_obj = $actions->{private}->{$uid}->{$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;