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         $command_copy =
 141           Catalyst::Utils::class2prefix( $caller, $c->config->{case_sensitive} )
 142           . "/${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         $namespace = '' if $namespace eq '/';
 268         my $parent = $self->tree;
 269         my @results;
 270
 271         if ($inherit) {
 272             my $result =
 273               $self->actions->{private}->{ $parent->getUID }->{$action};
 274             push @results, [$result] if $result;
 275             my $visitor = Tree::Simple::Visitor::FindByPath->new;
 276
 277           SEARCH:
 278             for my $part ( split '/', $namespace ) {
 279                 $visitor->setSearchPath($part);
 280                 $parent->accept($visitor);
 281                 my $child = $visitor->getResult;
 282                 my $uid   = $child->getUID if $child;
 283                 my $match = $self->actions->{private}->{$uid}->{$action}
 284                   if $uid;
 285                 push @results, [$match] if $match;
 286                 if ($child) {
 287                     $parent = $child;
 288                 }
 289                 else {
 290                     last SEARCH;
 291                 }
 292             }
 293
 294         }
 295
 296         else {
 297
 298             if ($namespace) {
 299                 my $visitor = Tree::Simple::Visitor::FindByPath->new;
 300                 $visitor->setSearchPath( split '/', $namespace );
 301                 $parent->accept($visitor);
 302                 my $child = $visitor->getResult;
 303                 my $uid   = $child->getUID if $child;
 304                 my $match = $self->actions->{private}->{$uid}->{$action}
 305                   if $uid;
 306                 push @results, [$match] if $match;
 307             }
 308
 309             else {
 310                 my $result =
 311                   $self->actions->{private}->{ $parent->getUID }->{$action};
 312                 push @results, [$result] if $result;
 313             }
 314
 315         }
 316         return \@results;
 317     }
 318
 319     elsif ( my $p = $self->actions->{plain}->{$action} ) { return [ [$p] ] }
 320     elsif ( my $r = $self->actions->{regex}->{$action} ) { return [ [$r] ] }
 321
 322     else {
 323
 324         for my $i ( 0 .. $#{ $self->actions->{compiled} } ) {
 325             my $name  = $self->actions->{compiled}->[$i]->[0];
 326             my $regex = $self->actions->{compiled}->[$i]->[1];
 327
 328             if ( my @snippets = ( $action =~ $regex ) ) {
 329                 return [
 330                     [ $self->actions->{regex}->{$name}, $name, \@snippets ] ];
 331             }
 332
 333         }
 334     }
 335     return [];
 336 }
 337
 338 =item $self->set_action( $c, $action, $code, $namespace, $attrs )
 339
 340 =cut
 341
 342 sub set_action {
 343     my ( $self, $c, $method, $code, $namespace, $attrs ) = @_;
 344
 345     my $prefix =
 346       Catalyst::Utils::class2prefix( $namespace, $c->config->{case_sensitive} )
 347       || '';
 348     my %flags;
 349
 350     for my $attr ( @{$attrs} ) {
 351         if    ( $attr =~ /^(Local|Relative)$/ )    { $flags{local}++ }
 352         elsif ( $attr =~ /^(Global|Absolute)$/ )   { $flags{global}++ }
 353         elsif ( $attr =~ /^Path\(\s*(.+)\s*\)$/i ) {
 354             push @{ $flags{path} }, $1;
 355         }
 356         elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
 357         elsif ( $attr =~ /^(Regex|Regexp)\(\s*(.+)\s*\)$/i ) {
 358             push @{ $flags{regex} }, $2;
 359         }
 360     }
 361
 362     if ( $flags{private} && ( keys %flags > 1 ) ) {
 363         $c->log->debug( 'Bad action definition "'
 364               . join( ' ', @{$attrs} )
 365               . qq/" for "$namespace->$method"/ )
 366           if $c->debug;
 367         return;
 368     }
 369     return unless keys %flags;
 370
 371     my $parent  = $self->tree;
 372     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 373
 374     for my $part ( split '/', $prefix ) {
 375         $visitor->setSearchPath($part);
 376         $parent->accept($visitor);
 377         my $child = $visitor->getResult;
 378
 379         unless ($child) {
 380             $child = $parent->addChild( Tree::Simple->new($part) );
 381             $visitor->setSearchPath($part);
 382             $parent->accept($visitor);
 383             $child = $visitor->getResult;
 384         }
 385
 386         $parent = $child;
 387     }
 388
 389     my $reverse = $prefix ? "$prefix/$method" : $method;
 390
 391     my $action = Catalyst::Action->new(
 392         {
 393             code      => $code,
 394             reverse   => $reverse,
 395             namespace => $namespace,
 396         }
 397     );
 398
 399     my $uid = $parent->getUID;
 400     $self->actions->{private}->{$uid}->{$method} = $action;
 401
 402     my @path;
 403     for my $path ( @{ $flags{path} } ) {
 404         $path =~ s/^\w+//;
 405         $path =~ s/\w+$//;
 406         if ( $path =~ /^\s*'(.*)'\s*$/ ) { $path = $1 }
 407         if ( $path =~ /^\s*"(.*)"\s*$/ ) { $path = $1 }
 408         push @path, $path;
 409     }
 410     $flags{path} = \@path;
 411
 412     my @regex;
 413     for my $regex ( @{ $flags{regex} } ) {
 414         $regex =~ s/^\w+//;
 415         $regex =~ s/\w+$//;
 416         if ( $regex =~ /^\s*'(.*)'\s*$/ ) { $regex = $1 }
 417         if ( $regex =~ /^\s*"(.*)"\s*$/ ) { $regex = $1 }
 418         push @regex, $regex;
 419     }
 420     $flags{regex} = \@regex;
 421
 422     if ( $flags{local} || $flags{global} ) {
 423         push( @{ $flags{path} }, $prefix ? "/$prefix/$method" : "/$method" )
 424           if $flags{local};
 425
 426         push( @{ $flags{path} }, "/$method" ) if $flags{global};
 427     }
 428
 429     for my $path ( @{ $flags{path} } ) {
 430         if ( $path =~ /^\// ) { $path =~ s/^\/// }
 431         else { $path = $prefix ? "$prefix/$path" : $path }
 432         $self->actions->{plain}->{$path} = $action;
 433     }
 434
 435     for my $regex ( @{ $flags{regex} } ) {
 436         push @{ $self->actions->{compiled} }, [ $regex, qr#$regex# ];
 437         $self->actions->{regex}->{$regex} = $action;
 438     }
 439 }
 440
 441 =item $self->setup_actions( $class, $component )
 442
 443 =cut
 444
 445 sub setup_actions {
 446     my ( $self, $class ) = @_;
 447
 448     # These are the core structures
 449     $self->actions(
 450         {
 451             plain    => {},
 452             private  => {},
 453             regex    => {},
 454             compiled => []
 455         }
 456     );
 457
 458     # We use a tree
 459     $self->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
 460
 461     for my $comp ( keys %{ $class->components } ) {
 462
 463         # We only setup components that inherit from Catalyst::Base
 464         next unless $comp->isa('Catalyst::Base');
 465
 466         for my $action ( @{ Catalyst::Utils::reflect_actions($comp) } ) {
 467             my ( $code, $attrs ) = @{$action};
 468             my $name = '';
 469             no strict 'refs';
 470             my @cache = ( $comp, @{"$comp\::ISA"} );
 471             my %namespaces;
 472
 473             while ( my $namespace = shift @cache ) {
 474                 $namespaces{$namespace}++;
 475                 for my $isa ( @{"$comp\::ISA"} ) {
 476                     next if $namespaces{$isa};
 477                     push @cache, $isa;
 478                     $namespaces{$isa}++;
 479                 }
 480             }
 481
 482             for my $namespace ( keys %namespaces ) {
 483
 484                 for my $sym ( values %{ $namespace . '::' } ) {
 485
 486                     if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
 487
 488                         $name = *{$sym}{NAME};
 489                         $class->set_action( $name, $code, $comp, $attrs );
 490                         last;
 491                     }
 492
 493                 }
 494
 495             }
 496
 497         }
 498
 499     }
 500
 501     return unless $class->debug;
 502
 503     my $actions  = $self->actions;
 504     my $privates = Text::ASCIITable->new;
 505     $privates->setCols( 'Private', 'Class' );
 506     $privates->setColWidth( 'Private', 36, 1 );
 507     $privates->setColWidth( 'Class',   37, 1 );
 508
 509     my $walker = sub {
 510         my ( $walker, $parent, $prefix ) = @_;
 511         $prefix .= $parent->getNodeValue || '';
 512         $prefix .= '/' unless $prefix =~ /\/$/;
 513         my $uid = $parent->getUID;
 514
 515         for my $action ( keys %{ $actions->{private}->{$uid} } ) {
 516             my $action_obj = $actions->{private}->{$uid}->{$action};
 517             $privates->addRow( "$prefix$action", $action_obj->namespace );
 518         }
 519
 520         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 521     };
 522
 523     $walker->( $walker, $self->tree, '' );
 524     $class->log->debug( "Loaded private actions:\n" . $privates->draw )
 525       if ( @{ $privates->{tbl_rows} } );
 526
 527     my $publics = Text::ASCIITable->new;
 528     $publics->setCols( 'Public', 'Private' );
 529     $publics->setColWidth( 'Public',  36, 1 );
 530     $publics->setColWidth( 'Private', 37, 1 );
 531
 532     for my $plain ( sort keys %{ $actions->{plain} } ) {
 533         my $action = $actions->{plain}->{$plain};
 534         $publics->addRow( "/$plain", "/$action" );
 535     }
 536
 537     $class->log->debug( "Loaded public actions:\n" . $publics->draw )
 538       if ( @{ $publics->{tbl_rows} } );
 539
 540     my $regexes = Text::ASCIITable->new;
 541     $regexes->setCols( 'Regex', 'Private' );
 542     $regexes->setColWidth( 'Regex',   36, 1 );
 543     $regexes->setColWidth( 'Private', 37, 1 );
 544
 545     for my $regex ( sort keys %{ $actions->{regex} } ) {
 546         my $action = $actions->{regex}->{$regex};
 547         $regexes->addRow( $regex, "/$action" );
 548     }
 549
 550     $class->log->debug( "Loaded regex actions:\n" . $regexes->draw )
 551       if ( @{ $regexes->{tbl_rows} } );
 552 }
 553
 554 =back
 555
 556 =head1 AUTHOR
 557
 558 Sebastian Riedel, C<sri@cpan.org>
 559
 560 =head1 COPYRIGHT
 561
 562 This program is free software, you can redistribute it and/or modify it under
 563 the same terms as Perl itself.
 564
 565 =cut
 566
 567 1;