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