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                 if ( $results = $c->get_action( $tail, $1 ) ) {
 148                     $command   = $tail;
 149                     $namespace = $command_copy;
 150                     push( @{$arguments}, @extra_args );
 151                     last DESCEND;
 152                 }
 153                 unshift( @extra_args, $tail );
 154             }
 155         }
 156         $command =~ s/^\///;
 157     }
 158
 159     else {
 160         $namespace =
 161           Catalyst::Utils::class2prefix( $caller, $c->config->{case_sensitive} )
 162           || '/';
 163         $results = $c->get_action( $command, $namespace );
 164     }
 165
 166     unless ( @{$results} ) {
 167
 168         unless ( $c->components->{$command} ) {
 169             my $error =
 170 qq/Couldn't forward to command "$command". Invalid action or component./;
 171             $c->error($error);
 172             $c->log->debug($error) if $c->debug;
 173             return 0;
 174         }
 175
 176         my $class  = $command;
 177         my $method = shift || 'process';
 178
 179         if ( my $code = $c->components->{$class}->can($method) ) {
 180             my $action = Catalyst::Action->new(
 181                 {
 182                     code      => $code,
 183                     reverse   => "$class->$method",
 184                     namespace => $class,
 185                 }
 186             );
 187             $results = [ [$action] ];
 188         }
 189
 190         else {
 191             my $error =
 192               qq/Couldn't forward to "$class". Does not implement "$method"/;
 193             $c->error($error);
 194             $c->log->debug($error)
 195               if $c->debug;
 196             return 0;
 197         }
 198
 199     }
 200
 201     local $c->request->{arguments} = [ @{$arguments} ];
 202
 203     for my $result ( @{$results} ) {
 204         $result->[0]->execute($c);
 205         return if scalar @{ $c->error };
 206         last unless $c->state;
 207     }
 208
 209     return $c->state;
 210 }
 211
 212 =item $self->prepare_action($c)
 213
 214 =cut
 215
 216 sub prepare_action {
 217     my ( $self, $c ) = @_;
 218     my $path = $c->req->path;
 219     my @path = split /\//, $c->req->path;
 220     $c->req->args( \my @args );
 221
 222     while (@path) {
 223         $path = join '/', @path;
 224         if ( my $result = ${ $c->get_action($path) }[0] ) {
 225
 226             # It's a regex
 227             if ($#$result) {
 228                 my $match    = $result->[1];
 229                 my @snippets = @{ $result->[2] };
 230                 $c->log->debug(
 231                     qq/Requested action is "$path" and matched "$match"/)
 232                   if $c->debug;
 233                 $c->log->debug(
 234                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 235                   if ( $c->debug && @snippets );
 236                 $c->req->action($match);
 237                 $c->req->snippets( \@snippets );
 238             }
 239
 240             else {
 241                 $c->req->action($path);
 242                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 243             }
 244
 245             $c->req->match($path);
 246             last;
 247         }
 248         unshift @args, pop @path;
 249     }
 250
 251     unless ( $c->req->action ) {
 252         $c->req->action('default');
 253         $c->req->match('');
 254     }
 255
 256     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 257       if ( $c->debug && @args );
 258 }
 259
 260 =item $self->get_action( $c, $action, $namespace, $inherit )
 261
 262 =cut
 263
 264 sub get_action {
 265     my ( $self, $c, $action, $namespace, $inherit ) = @_;
 266     return [] unless $action;
 267     $namespace ||= '';
 268     $inherit   ||= 0;
 269
 270     if ($namespace) {
 271         $namespace = '' if $namespace eq '/';
 272         my $parent = $self->tree;
 273         my @results;
 274
 275         if ($inherit) {
 276             my $result =
 277               $self->actions->{private}->{ $parent->getUID }->{$action};
 278             push @results, [$result] if $result;
 279             my $visitor = Tree::Simple::Visitor::FindByPath->new;
 280
 281           SEARCH:
 282             for my $part ( split '/', $namespace ) {
 283                 $visitor->setSearchPath($part);
 284                 $parent->accept($visitor);
 285                 my $child = $visitor->getResult;
 286                 my $uid   = $child->getUID if $child;
 287                 my $match = $self->actions->{private}->{$uid}->{$action}
 288                   if $uid;
 289                 push @results, [$match] if $match;
 290                 if ($child) {
 291                     $parent = $child;
 292                 }
 293                 else {
 294                     last SEARCH;
 295                 }
 296             }
 297
 298         }
 299
 300         else {
 301
 302             if ($namespace) {
 303                 my $visitor = Tree::Simple::Visitor::FindByPath->new;
 304                 $visitor->setSearchPath( split '/', $namespace );
 305                 $parent->accept($visitor);
 306                 my $child = $visitor->getResult;
 307                 my $uid   = $child->getUID if $child;
 308                 my $match = $self->actions->{private}->{$uid}->{$action}
 309                   if $uid;
 310                 push @results, [$match] if $match;
 311             }
 312
 313             else {
 314                 my $result =
 315                   $self->actions->{private}->{ $parent->getUID }->{$action};
 316                 push @results, [$result] if $result;
 317             }
 318
 319         }
 320         return \@results;
 321     }
 322
 323     elsif ( my $p = $self->actions->{plain}->{$action} ) { return [ [$p] ] }
 324     elsif ( my $r = $self->actions->{regex}->{$action} ) { return [ [$r] ] }
 325
 326     else {
 327
 328         for my $i ( 0 .. $#{ $self->actions->{compiled} } ) {
 329             my $name  = $self->actions->{compiled}->[$i]->[0];
 330             my $regex = $self->actions->{compiled}->[$i]->[1];
 331
 332             if ( my @snippets = ( $action =~ $regex ) ) {
 333                 return [
 334                     [ $self->actions->{regex}->{$name}, $name, \@snippets ] ];
 335             }
 336
 337         }
 338     }
 339     return [];
 340 }
 341
 342 =item $self->set_action( $c, $action, $code, $namespace, $attrs )
 343
 344 =cut
 345
 346 sub set_action {
 347     my ( $self, $c, $method, $code, $namespace, $attrs ) = @_;
 348
 349     my $prefix =
 350       Catalyst::Utils::class2prefix( $namespace, $c->config->{case_sensitive} )
 351       || '';
 352     my %flags;
 353
 354     for my $attr ( @{$attrs} ) {
 355         if    ( $attr =~ /^(Local|Relative)$/ )    { $flags{local}++ }
 356         elsif ( $attr =~ /^(Global|Absolute)$/ )   { $flags{global}++ }
 357         elsif ( $attr =~ /^Path\(\s*(.+)\s*\)$/i ) { $flags{path} = $1 }
 358         elsif ( $attr =~ /^Private$/i )            { $flags{private}++ }
 359         elsif ( $attr =~ /^(Regex|Regexp)\(\s*(.+)\s*\)$/i ) {
 360             $flags{regex} = $2;
 361         }
 362     }
 363
 364     if ( $flags{private} && ( keys %flags > 1 ) ) {
 365         $c->log->debug( 'Bad action definition "'
 366               . join( ' ', @{$attrs} )
 367               . qq/" for "$namespace->$method"/ )
 368           if $c->debug;
 369         return;
 370     }
 371     return unless keys %flags;
 372
 373     my $parent  = $self->tree;
 374     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 375
 376     for my $part ( split '/', $prefix ) {
 377         $visitor->setSearchPath($part);
 378         $parent->accept($visitor);
 379         my $child = $visitor->getResult;
 380
 381         unless ($child) {
 382             $child = $parent->addChild( Tree::Simple->new($part) );
 383             $visitor->setSearchPath($part);
 384             $parent->accept($visitor);
 385             $child = $visitor->getResult;
 386         }
 387
 388         $parent = $child;
 389     }
 390
 391     my $forward = $prefix ? "$prefix/$method" : $method;
 392
 393     my $reverse = $prefix ? "$prefix/$method" : $method;
 394
 395     my $action = Catalyst::Action->new(
 396         {
 397             code      => $code,
 398             reverse   => $reverse,
 399             namespace => $namespace,
 400         }
 401     );
 402
 403     my $uid = $parent->getUID;
 404     $self->actions->{private}->{$uid}->{$method} = $action;
 405
 406     if ( $flags{path} ) {
 407         $flags{path} =~ s/^\w+//;
 408         $flags{path} =~ s/\w+$//;
 409         if ( $flags{path} =~ /^\s*'(.*)'\s*$/ ) { $flags{path} = $1 }
 410         if ( $flags{path} =~ /^\s*"(.*)"\s*$/ ) { $flags{path} = $1 }
 411     }
 412
 413     if ( $flags{regex} ) {
 414         $flags{regex} =~ s/^\w+//;
 415         $flags{regex} =~ s/\w+$//;
 416         if ( $flags{regex} =~ /^\s*'(.*)'\s*$/ ) { $flags{regex} = $1 }
 417         if ( $flags{regex} =~ /^\s*"(.*)"\s*$/ ) { $flags{regex} = $1 }
 418     }
 419
 420     if ( $flags{local} || $flags{global} || $flags{path} ) {
 421         my $path     = $flags{path} || $method;
 422         my $absolute = 0;
 423
 424         if ( $path =~ /^\/(.+)/ ) {
 425             $path     = $1;
 426             $absolute = 1;
 427         }
 428
 429         $absolute = 1 if $flags{global};
 430         my $name = $absolute ? $path : $prefix ? "$prefix/$path" : $path;
 431         $self->actions->{plain}->{$name} = $action;
 432     }
 433
 434     if ( my $regex = $flags{regex} ) {
 435         push @{ $self->actions->{compiled} }, [ $regex, qr#$regex# ];
 436         $self->actions->{regex}->{$regex} = $action;
 437     }
 438 }
 439
 440 =item $self->setup_actions( $class, $component )
 441
 442 =cut
 443
 444 sub setup_actions {
 445     my ( $self, $class ) = @_;
 446
 447     # These are the core structures
 448     $self->actions(
 449         {
 450             plain    => {},
 451             private  => {},
 452             regex    => {},
 453             compiled => []
 454         }
 455     );
 456
 457     # We use a tree
 458     $self->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
 459
 460     for my $comp ( keys %{ $class->components } ) {
 461
 462         # We only setup components that inherit from Catalyst::Base
 463         next unless $comp->isa('Catalyst::Base');
 464
 465         for my $action ( @{ Catalyst::Utils::reflect_actions($comp) } ) {
 466             my ( $code, $attrs ) = @{$action};
 467             my $name = '';
 468             no strict 'refs';
 469             my @cache = ( $comp, @{"$comp\::ISA"} );
 470             my %namespaces;
 471
 472             while ( my $namespace = shift @cache ) {
 473                 $namespaces{$namespace}++;
 474                 for my $isa ( @{"$comp\::ISA"} ) {
 475                     next if $namespaces{$isa};
 476                     push @cache, $isa;
 477                     $namespaces{$isa}++;
 478                 }
 479             }
 480
 481             for my $namespace ( keys %namespaces ) {
 482
 483                 for my $sym ( values %{ $namespace . '::' } ) {
 484
 485                     if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
 486
 487                         $name = *{$sym}{NAME};
 488                         $class->set_action( $name, $code, $comp, $attrs );
 489                         last;
 490                     }
 491
 492                 }
 493
 494             }
 495
 496         }
 497
 498     }
 499
 500     return unless $class->debug;
 501
 502     my $actions  = $self->actions;
 503     my $privates = Text::ASCIITable->new;
 504     $privates->setCols( 'Private', 'Class' );
 505     $privates->setColWidth( 'Private', 36, 1 );
 506     $privates->setColWidth( 'Class',   37, 1 );
 507
 508     my $walker = sub {
 509         my ( $walker, $parent, $prefix ) = @_;
 510         $prefix .= $parent->getNodeValue || '';
 511         $prefix .= '/' unless $prefix =~ /\/$/;
 512         my $uid = $parent->getUID;
 513
 514         for my $action ( keys %{ $actions->{private}->{$uid} } ) {
 515             my $action_obj = $actions->{private}->{$uid}->{$action};
 516             $privates->addRow( "$prefix$action", $action_obj->namespace );
 517         }
 518
 519         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 520     };
 521
 522     $walker->( $walker, $self->tree, '' );
 523     $class->log->debug( "Loaded private actions:\n" . $privates->draw )
 524       if ( @{ $privates->{tbl_rows} } );
 525
 526     my $publics = Text::ASCIITable->new;
 527     $publics->setCols( 'Public', 'Private' );
 528     $publics->setColWidth( 'Public',  36, 1 );
 529     $publics->setColWidth( 'Private', 37, 1 );
 530
 531     for my $plain ( sort keys %{ $actions->{plain} } ) {
 532         my $action = $actions->{plain}->{$plain};
 533         $publics->addRow( "/$plain", "/$action" );
 534     }
 535
 536     $class->log->debug( "Loaded public actions:\n" . $publics->draw )
 537       if ( @{ $publics->{tbl_rows} } );
 538
 539     my $regexes = Text::ASCIITable->new;
 540     $regexes->setCols( 'Regex', 'Private' );
 541     $regexes->setColWidth( 'Regex',   36, 1 );
 542     $regexes->setColWidth( 'Private', 37, 1 );
 543
 544     for my $regex ( sort keys %{ $actions->{regex} } ) {
 545         my $action = $actions->{regex}->{$regex};
 546         $regexes->addRow( $regex, "/$action" );
 547     }
 548
 549     $class->log->debug( "Loaded regex actions:\n" . $regexes->draw )
 550       if ( @{ $regexes->{tbl_rows} } );
 551 }
 552
 553 =back
 554
 555 =head1 AUTHOR
 556
 557 Sebastian Riedel, C<sri@cpan.org>
 558
 559 =head1 COPYRIGHT
 560
 561 This program is free software, you can redistribute it and/or modify it under
 562 the same terms as Perl itself.
 563
 564 =cut
 565
 566 1;