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 $namespace = '/';
 134     my $arguments = ( ref( $_[-1] ) eq 'ARRAY' ) ? pop(@_) : $c->req->args;
 135
 136     my $results = [];
 137
 138     if ( $command =~ /^\// ) {
 139         if ( $command =~ /^\/(\w+)$/ ) {
 140             $results = $c->get_action( $1, $namespace );
 141         }
 142         else {
 143             my $command_copy = $command;
 144             my @extra_args;
 145           DESCEND: while ( $command_copy =~ s/^\/(.*)\/(\w+)$/\/$1/ ) {
 146                 my $tail = $2;
 147                 $results = $c->get_action( $tail, $1 );
 148                 if ( @{$results} ) {
 149                     $command   = $tail;
 150                     $namespace = $command_copy;
 151                     push( @{$arguments}, @extra_args );
 152                     last DESCEND;
 153                 }
 154                 unshift( @extra_args, $tail );
 155             }
 156         }
 157         $command =~ s/^\///;
 158     }
 159
 160     else {
 161         $namespace =
 162           Catalyst::Utils::class2prefix( $caller, $c->config->{case_sensitive} )
 163           || '/';
 164         $results = $c->get_action( $command, $namespace );
 165     }
 166
 167     unless ( @{$results} ) {
 168
 169         unless ( $c->components->{$command} ) {
 170             my $error =
 171 qq/Couldn't forward to command "$command". Invalid action or component./;
 172             $c->error($error);
 173             $c->log->debug($error) if $c->debug;
 174             return 0;
 175         }
 176
 177         my $class  = $command;
 178         my $method = shift || 'process';
 179
 180         if ( my $code = $c->components->{$class}->can($method) ) {
 181             my $action = Catalyst::Action->new(
 182                 {
 183                     code      => $code,
 184                     reverse   => "$class->$method",
 185                     namespace => $class,
 186                 }
 187             );
 188             $results = [ [$action] ];
 189         }
 190
 191         else {
 192             my $error =
 193               qq/Couldn't forward to "$class". Does not implement "$method"/;
 194             $c->error($error);
 195             $c->log->debug($error)
 196               if $c->debug;
 197             return 0;
 198         }
 199
 200     }
 201
 202     local $c->request->{arguments} = [ @{$arguments} ];
 203
 204     for my $result ( @{$results} ) {
 205         $result->[0]->execute($c);
 206         return if scalar @{ $c->error };
 207         last unless $c->state;
 208     }
 209
 210     return $c->state;
 211 }
 212
 213 =item $self->prepare_action($c)
 214
 215 =cut
 216
 217 sub prepare_action {
 218     my ( $self, $c ) = @_;
 219     my $path = $c->req->path;
 220     my @path = split /\//, $c->req->path;
 221     $c->req->args( \my @args );
 222
 223     while (@path) {
 224         $path = join '/', @path;
 225         if ( my $result = ${ $c->get_action($path) }[0] ) {
 226
 227             # It's a regex
 228             if ($#$result) {
 229                 my $match    = $result->[1];
 230                 my @snippets = @{ $result->[2] };
 231                 $c->log->debug(
 232                     qq/Requested action is "$path" and matched "$match"/)
 233                   if $c->debug;
 234                 $c->log->debug(
 235                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 236                   if ( $c->debug && @snippets );
 237                 $c->req->action($match);
 238                 $c->req->snippets( \@snippets );
 239             }
 240
 241             else {
 242                 $c->req->action($path);
 243                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 244             }
 245
 246             $c->req->match($path);
 247             last;
 248         }
 249         unshift @args, pop @path;
 250     }
 251
 252     unless ( $c->req->action ) {
 253         $c->req->action('default');
 254         $c->req->match('');
 255     }
 256
 257     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 258       if ( $c->debug && @args );
 259 }
 260
 261 =item $self->get_action( $c, $action, $namespace, $inherit )
 262
 263 =cut
 264
 265 sub get_action {
 266     my ( $self, $c, $action, $namespace, $inherit ) = @_;
 267     return [] unless $action;
 268     $namespace ||= '';
 269     $inherit   ||= 0;
 270
 271     if ($namespace) {
 272         $namespace = '' if $namespace eq '/';
 273         my $parent = $self->tree;
 274         my @results;
 275
 276         if ($inherit) {
 277             my $result =
 278               $self->actions->{private}->{ $parent->getUID }->{$action};
 279             push @results, [$result] if $result;
 280             my $visitor = Tree::Simple::Visitor::FindByPath->new;
 281
 282           SEARCH:
 283             for my $part ( split '/', $namespace ) {
 284                 $visitor->setSearchPath($part);
 285                 $parent->accept($visitor);
 286                 my $child = $visitor->getResult;
 287                 my $uid   = $child->getUID if $child;
 288                 my $match = $self->actions->{private}->{$uid}->{$action}
 289                   if $uid;
 290                 push @results, [$match] if $match;
 291                 if ($child) {
 292                     $parent = $child;
 293                 }
 294                 else {
 295                     last SEARCH;
 296                 }
 297             }
 298
 299         }
 300
 301         else {
 302
 303             if ($namespace) {
 304                 my $visitor = Tree::Simple::Visitor::FindByPath->new;
 305                 $visitor->setSearchPath( split '/', $namespace );
 306                 $parent->accept($visitor);
 307                 my $child = $visitor->getResult;
 308                 my $uid   = $child->getUID if $child;
 309                 my $match = $self->actions->{private}->{$uid}->{$action}
 310                   if $uid;
 311                 push @results, [$match] if $match;
 312             }
 313
 314             else {
 315                 my $result =
 316                   $self->actions->{private}->{ $parent->getUID }->{$action};
 317                 push @results, [$result] if $result;
 318             }
 319
 320         }
 321         return \@results;
 322     }
 323
 324     elsif ( my $p = $self->actions->{plain}->{$action} ) { return [ [$p] ] }
 325     elsif ( my $r = $self->actions->{regex}->{$action} ) { return [ [$r] ] }
 326
 327     else {
 328
 329         for my $i ( 0 .. $#{ $self->actions->{compiled} } ) {
 330             my $name  = $self->actions->{compiled}->[$i]->[0];
 331             my $regex = $self->actions->{compiled}->[$i]->[1];
 332
 333             if ( my @snippets = ( $action =~ $regex ) ) {
 334                 return [
 335                     [ $self->actions->{regex}->{$name}, $name, \@snippets ] ];
 336             }
 337
 338         }
 339     }
 340     return [];
 341 }
 342
 343 =item $self->set_action( $c, $action, $code, $namespace, $attrs )
 344
 345 =cut
 346
 347 sub set_action {
 348     my ( $self, $c, $method, $code, $namespace, $attrs ) = @_;
 349
 350     my $prefix =
 351       Catalyst::Utils::class2prefix( $namespace, $c->config->{case_sensitive} )
 352       || '';
 353     my %flags;
 354
 355     for my $attr ( @{$attrs} ) {
 356         if    ( $attr =~ /^(Local|Relative)$/ )    { $flags{local}++ }
 357         elsif ( $attr =~ /^(Global|Absolute)$/ )   { $flags{global}++ }
 358         elsif ( $attr =~ /^Path\(\s*(.+)\s*\)$/i ) {
 359             push @{ $flags{path} }, $1;
 360         }
 361         elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
 362         elsif ( $attr =~ /^(Regex|Regexp)\(\s*(.+)\s*\)$/i ) {
 363             push @{ $flags{regex} }, $2;
 364         }
 365     }
 366
 367     if ( $flags{private} && ( keys %flags > 1 ) ) {
 368         $c->log->debug( 'Bad action definition "'
 369               . join( ' ', @{$attrs} )
 370               . qq/" for "$namespace->$method"/ )
 371           if $c->debug;
 372         return;
 373     }
 374     return unless keys %flags;
 375
 376     my $parent  = $self->tree;
 377     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 378
 379     for my $part ( split '/', $prefix ) {
 380         $visitor->setSearchPath($part);
 381         $parent->accept($visitor);
 382         my $child = $visitor->getResult;
 383
 384         unless ($child) {
 385             $child = $parent->addChild( Tree::Simple->new($part) );
 386             $visitor->setSearchPath($part);
 387             $parent->accept($visitor);
 388             $child = $visitor->getResult;
 389         }
 390
 391         $parent = $child;
 392     }
 393
 394     my $reverse = $prefix ? "$prefix/$method" : $method;
 395
 396     my $action = Catalyst::Action->new(
 397         {
 398             code      => $code,
 399             reverse   => $reverse,
 400             namespace => $namespace,
 401         }
 402     );
 403
 404     my $uid = $parent->getUID;
 405     $self->actions->{private}->{$uid}->{$method} = $action;
 406
 407     my @path;
 408     for my $path ( @{ $flags{path} } ) {
 409         $path =~ s/^\w+//;
 410         $path =~ s/\w+$//;
 411         if ( $path =~ /^\s*'(.*)'\s*$/ ) { $path = $1 }
 412         if ( $path =~ /^\s*"(.*)"\s*$/ ) { $path = $1 }
 413         push @path, $path;
 414     }
 415     $flags{path} = \@path;
 416
 417     my @regex;
 418     for my $regex ( @{ $flags{regex} } ) {
 419         $regex =~ s/^\w+//;
 420         $regex =~ s/\w+$//;
 421         if ( $regex =~ /^\s*'(.*)'\s*$/ ) { $regex = $1 }
 422         if ( $regex =~ /^\s*"(.*)"\s*$/ ) { $regex = $1 }
 423         push @regex, $regex;
 424     }
 425     $flags{regex} = \@regex;
 426
 427     if ( $flags{local} || $flags{global} ) {
 428         push( @{ $flags{path} }, $prefix ? "/$prefix/$method" : "/$method" )
 429           if $flags{local};
 430
 431         push( @{ $flags{path} }, "/$method" ) if $flags{global};
 432     }
 433
 434     for my $path ( @{ $flags{path} } ) {
 435         if ( $path =~ /^\// ) { $path =~ s/^\/// }
 436         else { $path = $prefix ? "$prefix/$path" : $path }
 437         $self->actions->{plain}->{$path} = $action;
 438     }
 439
 440     for my $regex ( @{ $flags{regex} } ) {
 441         push @{ $self->actions->{compiled} }, [ $regex, qr#$regex# ];
 442         $self->actions->{regex}->{$regex} = $action;
 443     }
 444 }
 445
 446 =item $self->setup_actions( $class, $component )
 447
 448 =cut
 449
 450 sub setup_actions {
 451     my ( $self, $class ) = @_;
 452
 453     # These are the core structures
 454     $self->actions(
 455         {
 456             plain    => {},
 457             private  => {},
 458             regex    => {},
 459             compiled => []
 460         }
 461     );
 462
 463     # We use a tree
 464     $self->tree( Tree::Simple->new( 0, 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 $uid = $parent->getUID;
 519
 520         for my $action ( keys %{ $actions->{private}->{$uid} } ) {
 521             my $action_obj = $actions->{private}->{$uid}->{$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;