lib/Catalyst/Engine.pm

   1 package Catalyst::Engine;
   2
   3 use strict;
   4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
   5 use UNIVERSAL::require;
   6 use CGI::Cookie;
   7 use Data::Dumper;
   8 use HTML::Entities;
   9 use HTTP::Headers;
  10 use Memoize;
  11 use Time::HiRes qw/gettimeofday tv_interval/;
  12 use Text::ASCIITable;
  13 use Text::ASCIITable::Wrap 'wrap';
  14 use Tree::Simple;
  15 use Tree::Simple::Visitor::FindByPath;
  16 use Catalyst::Request;
  17 use Catalyst::Response;
  18
  19 require Module::Pluggable::Fast;
  20
  21 $Data::Dumper::Terse = 1;
  22
  23 __PACKAGE__->mk_classdata($_) for qw/actions components tree/;
  24 __PACKAGE__->mk_accessors(qw/request response state/);
  25
  26 __PACKAGE__->actions(
  27     { plain => {}, private => {}, regex => {}, compiled => [], reverse => {} }
  28 );
  29 __PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
  30
  31 *comp = \&component;
  32 *req  = \&request;
  33 *res  = \&response;
  34
  35 our $COUNT = 1;
  36 our $START = time;
  37
  38 memoize('_class2prefix');
  39
  40 =head1 NAME
  41
  42 Catalyst::Engine - The Catalyst Engine
  43
  44 =head1 SYNOPSIS
  45
  46 See L<Catalyst>.
  47
  48 =head1 DESCRIPTION
  49
  50 =head1 METHODS
  51
  52 =over 4
  53
  54 =item $c->benchmark($coderef)
  55
  56 Takes a coderef with arguments and returns elapsed time as float.
  57
  58     my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
  59     $c->log->info( sprintf "Processing took %f seconds", $elapsed );
  60
  61 =cut
  62
  63 sub benchmark {
  64     my $c       = shift;
  65     my $code    = shift;
  66     my $time    = [gettimeofday];
  67     my @return  = &$code(@_);
  68     my $elapsed = tv_interval $time;
  69     return wantarray ? ( $elapsed, @return ) : $elapsed;
  70 }
  71
  72 =item $c->comp($name)
  73
  74 =item $c->component($name)
  75
  76 Get a component object by name.
  77
  78     $c->comp('MyApp::Model::MyModel')->do_stuff;
  79
  80 Regex search for a component.
  81
  82     $c->comp('mymodel')->do_stuff;
  83
  84 =cut
  85
  86 sub component {
  87     my ( $c, $name ) = @_;
  88     if ( my $component = $c->components->{$name} ) {
  89         return $component;
  90     }
  91     else {
  92         for my $component ( keys %{ $c->components } ) {
  93             return $c->components->{$component} if $component =~ /$name/i;
  94         }
  95     }
  96 }
  97
  98 =item $c->dispatch
  99
 100 Dispatch request to actions.
 101
 102 =cut
 103
 104 sub dispatch {
 105     my $c         = shift;
 106     my $action    = $c->req->action;
 107     my $namespace = '';
 108     $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
 109       if $action eq 'default';
 110     unless ($namespace) {
 111         if ( my $result = $c->get_action($action) ) {
 112             $namespace = _class2prefix( $result->[0]->[0]->[0] );
 113         }
 114     }
 115     my $default = $action eq 'default' ? $namespace : undef;
 116     my $results = $c->get_action( $action, $default );
 117     $namespace ||= '/';
 118     if ( @{$results} ) {
 119
 120         # Execute last begin
 121         $c->state(1);
 122         if ( my $begin = @{ $c->get_action( 'begin', $namespace ) }[-1] ) {
 123             $c->execute( @{ $begin->[0] } );
 124         }
 125
 126         # Execute the auto chain
 127         for my $auto ( @{ $c->get_action( 'auto', $namespace ) } ) {
 128             $c->execute( @{ $auto->[0] } );
 129             last unless $c->state;
 130         }
 131
 132         # Execute the action or last default
 133         if ( ( my $action = $c->req->action ) && $c->state ) {
 134             if ( my $result = @{ $c->get_action( $action, $default ) }[-1] ) {
 135                 $c->execute( @{ $result->[0] } );
 136             }
 137         }
 138
 139         # Execute last end
 140         if ( my $end = @{ $c->get_action( 'end', $namespace ) }[-1] ) {
 141             $c->execute( @{ $end->[0] } );
 142         }
 143     }
 144     else {
 145         my $path  = $c->req->path;
 146         my $error = $path
 147           ? qq/Unknown resource "$path"/
 148           : "No default action defined";
 149         $c->log->error($error) if $c->debug;
 150         $c->error($error);
 151     }
 152 }
 153
 154 =item $c->error
 155
 156 =item $c->error($error, ...)
 157
 158 =item $c->error($arrayref)
 159
 160 Returns an arrayref containing error messages.
 161
 162     my @error = @{ $c->error };
 163
 164 Add a new error.
 165
 166     $c->error('Something bad happened');
 167
 168 =cut
 169
 170 sub error {
 171     my $c = shift;
 172     my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
 173     push @{ $c->{error} }, @$error;
 174     return $c->{error};
 175 }
 176
 177 =item $c->execute($class, $coderef)
 178
 179 Execute a coderef in given class and catch exceptions.
 180 Errors are available via $c->error.
 181
 182 =cut
 183
 184 sub execute {
 185     my ( $c, $class, $code ) = @_;
 186     $class = $c->comp($class) || $class;
 187     $c->state(0);
 188     my $callsub = ( caller(1) )[3];
 189     eval {
 190         if ( $c->debug )
 191         {
 192             my $action = $c->actions->{reverse}->{"$code"};
 193             $action = "/$action" unless $action =~ /\-\>/;
 194             $action = "-> $action" if $callsub =~ /forward$/;
 195             my ( $elapsed, @state ) =
 196               $c->benchmark( $code, $class, $c, @{ $c->req->args } );
 197             push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
 198             $c->state(@state);
 199         }
 200         else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
 201     };
 202     if ( my $error = $@ ) {
 203         chomp $error;
 204         $error = qq/Caught exception "$error"/;
 205         $c->log->error($error);
 206         $c->error($error) if $c->debug;
 207         $c->state(0);
 208     }
 209     return $c->state;
 210 }
 211
 212 =item $c->finalize
 213
 214 Finalize request.
 215
 216 =cut
 217
 218 sub finalize {
 219     my $c = shift;
 220
 221     $c->finalize_cookies;
 222
 223     if ( my $location = $c->response->redirect ) {
 224         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
 225         $c->response->header( Location => $location );
 226         $c->response->status(302) if $c->response->status !~ /3\d\d$/;
 227     }
 228
 229     if ( $#{ $c->error } >= 0 ) {
 230         $c->finalize_error;
 231     }
 232
 233     if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
 234         $c->finalize_error;
 235     }
 236
 237     if ( $c->response->output && !$c->response->content_length ) {
 238         use bytes;    # play safe with a utf8 aware perl
 239         $c->response->content_length( length $c->response->output );
 240     }
 241
 242     my $status = $c->finalize_headers;
 243     $c->finalize_output;
 244     return $status;
 245 }
 246
 247 =item $c->finalize_cookies
 248
 249 Finalize cookies.
 250
 251 =cut
 252
 253 sub finalize_cookies {
 254     my $c = shift;
 255
 256     while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
 257         my $cookie = CGI::Cookie->new(
 258             -name    => $name,
 259             -value   => $cookie->{value},
 260             -expires => $cookie->{expires},
 261             -domain  => $cookie->{domain},
 262             -path    => $cookie->{path},
 263             -secure  => $cookie->{secure} || 0
 264         );
 265
 266         $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
 267     }
 268 }
 269
 270 =item $c->finalize_error
 271
 272 Finalize error.
 273
 274 =cut
 275
 276 sub finalize_error {
 277     my $c = shift;
 278
 279     $c->res->headers->content_type('text/html');
 280     my $name = $c->config->{name} || 'Catalyst Application';
 281
 282     my ( $title, $error, $infos );
 283     if ( $c->debug ) {
 284         $error = join '<br/>', @{ $c->error };
 285         $error ||= 'No output';
 286         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 287         my $req   = encode_entities Dumper $c->req;
 288         my $res   = encode_entities Dumper $c->res;
 289         my $stash = encode_entities Dumper $c->stash;
 290         $infos = <<"";
 291 <br/>
 292 <b><u>Request</u></b><br/>
 293 <pre>$req</pre>
 294 <b><u>Response</u></b><br/>
 295 <pre>$res</pre>
 296 <b><u>Stash</u></b><br/>
 297 <pre>$stash</pre>
 298
 299     }
 300     else {
 301         $title = $name;
 302         $error = '';
 303         $infos = <<"";
 304 <pre>
 305 (en) Please come back later
 306 (de) Bitte versuchen sie es spaeter nocheinmal
 307 (nl) Gelieve te komen later terug
 308 (no) Vennligst prov igjen senere
 309 (fr) Veuillez revenir plus tard
 310 (es) Vuelto por favor mas adelante
 311 (pt) Voltado por favor mais tarde
 312 (it) Ritornato prego più successivamente
 313 </pre>
 314
 315         $name = '';
 316     }
 317     $c->res->output( <<"" );
 318 <html>
 319 <head>
 320     <title>$title</title>
 321     <style type="text/css">
 322         body {
 323             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 324                          Tahoma, Arial, helvetica, sans-serif;
 325             color: #ddd;
 326             background-color: #eee;
 327             margin: 0px;
 328             padding: 0px;
 329         }
 330         div.box {
 331             background-color: #ccc;
 332             border: 1px solid #aaa;
 333             padding: 4px;
 334             margin: 10px;
 335             -moz-border-radius: 10px;
 336         }
 337         div.error {
 338             background-color: #977;
 339             border: 1px solid #755;
 340             padding: 8px;
 341             margin: 4px;
 342             margin-bottom: 10px;
 343             -moz-border-radius: 10px;
 344         }
 345         div.infos {
 346             background-color: #797;
 347             border: 1px solid #575;
 348             padding: 8px;
 349             margin: 4px;
 350             margin-bottom: 10px;
 351             -moz-border-radius: 10px;
 352         }
 353         div.name {
 354             background-color: #779;
 355             border: 1px solid #557;
 356             padding: 8px;
 357             margin: 4px;
 358             -moz-border-radius: 10px;
 359         }
 360     </style>
 361 </head>
 362 <body>
 363     <div class="box">
 364         <div class="error">$error</div>
 365         <div class="infos">$infos</div>
 366         <div class="name">$name</div>
 367     </div>
 368 </body>
 369 </html>
 370
 371 }
 372
 373 =item $c->finalize_headers
 374
 375 Finalize headers.
 376
 377 =cut
 378
 379 sub finalize_headers { }
 380
 381 =item $c->finalize_output
 382
 383 Finalize output.
 384
 385 =cut
 386
 387 sub finalize_output { }
 388
 389 =item $c->forward($command)
 390
 391 Forward processing to a private action or a method from a class.
 392 If you define a class without method it will default to process().
 393
 394     $c->forward('/foo');
 395     $c->forward('index');
 396     $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
 397     $c->forward('MyApp::View::TT');
 398
 399 =cut
 400
 401 sub forward {
 402     my $c       = shift;
 403     my $command = shift;
 404     unless ($command) {
 405         $c->log->debug('Nothing to forward to') if $c->debug;
 406         return 0;
 407     }
 408     my $caller    = caller(0);
 409     my $namespace = '/';
 410     if ( $command =~ /^\// ) {
 411         $command =~ /^(.*)\/(\w+)$/;
 412         $namespace = $1 || '/';
 413         $command = $2;
 414     }
 415     else { $namespace = _class2prefix($caller) || '/' }
 416     my $results = $c->get_action( $command, $namespace );
 417     unless ( @{$results} ) {
 418         my $class = $command;
 419         if ( $class =~ /[^\w\:]/ ) {
 420             $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
 421             return 0;
 422         }
 423         my $method = shift || 'process';
 424         if ( my $code = $class->can($method) ) {
 425             $c->actions->{reverse}->{"$code"} = "$class->$method";
 426             $results = [ [ [ $class, $code ] ] ];
 427         }
 428         else {
 429             $c->log->debug(qq/Couldn't forward to "$class->$method"/)
 430               if $c->debug;
 431             return 0;
 432         }
 433     }
 434     for my $result ( @{$results} ) {
 435         $c->execute( @{ $result->[0] } );
 436     }
 437     return $c->state;
 438 }
 439
 440 =item $c->get_action( $action, $namespace )
 441
 442 Get an action in a given namespace.
 443
 444 =cut
 445
 446 sub get_action {
 447     my ( $c, $action, $namespace ) = @_;
 448     return [] unless $action;
 449     $namespace ||= '';
 450     if ($namespace) {
 451         $namespace = '' if $namespace eq '/';
 452         my $parent = $c->tree;
 453         my @results;
 454         my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
 455         push @results, [$result] if $result;
 456         my $visitor = Tree::Simple::Visitor::FindByPath->new;
 457         for my $part ( split '/', $namespace ) {
 458             $visitor->setSearchPath($part);
 459             $parent->accept($visitor);
 460             my $child = $visitor->getResult;
 461             my $uid   = $child->getUID if $child;
 462             my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
 463             push @results, [$match] if $match;
 464             $parent = $child if $child;
 465         }
 466         return \@results;
 467     }
 468     elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
 469     elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
 470     else {
 471         for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
 472             my $name  = $c->actions->{compiled}->[$i]->[0];
 473             my $regex = $c->actions->{compiled}->[$i]->[1];
 474             if ( $action =~ $regex ) {
 475                 my @snippets;
 476                 for my $i ( 1 .. 9 ) {
 477                     no strict 'refs';
 478                     last unless ${$i};
 479                     push @snippets, ${$i};
 480                 }
 481                 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
 482             }
 483         }
 484     }
 485     return [];
 486 }
 487
 488 =item $c->handler( $class, $r )
 489
 490 Handles the request.
 491
 492 =cut
 493
 494 sub handler {
 495     my ( $class, $engine ) = @_;
 496
 497     # Always expect worst case!
 498     my $status = -1;
 499     eval {
 500         my @stats = ();
 501         my $handler = sub {
 502             my $c = $class->prepare($engine);
 503             $c->{stats} = \@stats;
 504             $c->dispatch;
 505             return $c->finalize;
 506         };
 507         if ( $class->debug ) {
 508             my $elapsed;
 509             ( $elapsed, $status ) = $class->benchmark($handler);
 510             $elapsed = sprintf '%f', $elapsed;
 511             my $av = sprintf '%.3f', 1 / $elapsed;
 512             my $t = Text::ASCIITable->new;
 513             $t->setCols( 'Action', 'Time' );
 514             $t->setColWidth( 'Action', 64, 1 );
 515             $t->setColWidth( 'Time',   9,  1 );
 516
 517             for my $stat (@stats) {
 518                 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
 519             }
 520             $class->log->info( "Request took $elapsed" . "s ($av/s)",
 521                 $t->draw );
 522         }
 523         else { $status = &$handler }
 524     };
 525     if ( my $error = $@ ) {
 526         chomp $error;
 527         $class->log->error(qq/Caught exception in engine "$error"/);
 528     }
 529     $COUNT++;
 530     return $status;
 531 }
 532
 533 =item $c->prepare($r)
 534
 535 Turns the engine-specific request( Apache, CGI ... )
 536 into a Catalyst context .
 537
 538 =cut
 539
 540 sub prepare {
 541     my ( $class, $r ) = @_;
 542     my $c = bless {
 543         request => Catalyst::Request->new(
 544             {
 545                 arguments  => [],
 546                 cookies    => {},
 547                 headers    => HTTP::Headers->new,
 548                 parameters => {},
 549                 snippets   => [],
 550                 uploads    => {}
 551             }
 552         ),
 553         response => Catalyst::Response->new(
 554             { cookies => {}, headers => HTTP::Headers->new, status => 200 }
 555         ),
 556         stash => {},
 557         state => 0
 558     }, $class;
 559     if ( $c->debug ) {
 560         my $secs = time - $START || 1;
 561         my $av = sprintf '%.3f', $COUNT / $secs;
 562         $c->log->debug('**********************************');
 563         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 564         $c->log->debug('**********************************');
 565         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 566     }
 567     $c->prepare_request($r);
 568     $c->prepare_path;
 569     $c->prepare_headers;
 570     $c->prepare_cookies;
 571     $c->prepare_connection;
 572     my $method   = $c->req->method   || '';
 573     my $path     = $c->req->path     || '';
 574     my $hostname = $c->req->hostname || '';
 575     my $address  = $c->req->address  || '';
 576     $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
 577       if $c->debug;
 578     $c->prepare_action;
 579     $c->prepare_parameters;
 580
 581     if ( $c->debug && keys %{ $c->req->params } ) {
 582         my $t = Text::ASCIITable->new;
 583         $t->setCols( 'Key', 'Value' );
 584         $t->setColWidth( 'Key',   37, 1 );
 585         $t->setColWidth( 'Value', 36, 1 );
 586         for my $key ( keys %{ $c->req->params } ) {
 587             my $value = $c->req->params->{$key} || '';
 588             $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
 589         }
 590         $c->log->debug( 'Parameters are', $t->draw );
 591     }
 592     $c->prepare_uploads;
 593     return $c;
 594 }
 595
 596 =item $c->prepare_action
 597
 598 Prepare action.
 599
 600 =cut
 601
 602 sub prepare_action {
 603     my $c    = shift;
 604     my $path = $c->req->path;
 605     my @path = split /\//, $c->req->path;
 606     $c->req->args( \my @args );
 607     while (@path) {
 608         $path = join '/', @path;
 609         if ( my $result = ${ $c->get_action($path) }[0] ) {
 610
 611             # It's a regex
 612             if ($#$result) {
 613                 my $match    = $result->[1];
 614                 my @snippets = @{ $result->[2] };
 615                 $c->log->debug(
 616                     qq/Requested action is "$path" and matched "$match"/)
 617                   if $c->debug;
 618                 $c->log->debug(
 619                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 620                   if ( $c->debug && @snippets );
 621                 $c->req->action($match);
 622                 $c->req->snippets( \@snippets );
 623             }
 624             else {
 625                 $c->req->action($path);
 626                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 627             }
 628             $c->req->match($path);
 629             last;
 630         }
 631         unshift @args, pop @path;
 632     }
 633     unless ( $c->req->action ) {
 634         $c->req->action('default');
 635         $c->req->match('');
 636     }
 637     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 638       if ( $c->debug && @args );
 639 }
 640
 641 =item $c->prepare_connection
 642
 643 Prepare connection.
 644
 645 =cut
 646
 647 sub prepare_connection { }
 648
 649 =item $c->prepare_cookies
 650
 651 Prepare cookies.
 652
 653 =cut
 654
 655 sub prepare_cookies {
 656     my $c = shift;
 657
 658     if ( my $header = $c->request->header('Cookie') ) {
 659         $c->req->cookies( { CGI::Cookie->parse($header) } );
 660     }
 661 }
 662
 663 =item $c->prepare_headers
 664
 665 Prepare headers.
 666
 667 =cut
 668
 669 sub prepare_headers { }
 670
 671 =item $c->prepare_parameters
 672
 673 Prepare parameters.
 674
 675 =cut
 676
 677 sub prepare_parameters { }
 678
 679 =item $c->prepare_path
 680
 681 Prepare path and base.
 682
 683 =cut
 684
 685 sub prepare_path { }
 686
 687 =item $c->prepare_request
 688
 689 Prepare the engine request.
 690
 691 =cut
 692
 693 sub prepare_request { }
 694
 695 =item $c->prepare_uploads
 696
 697 Prepare uploads.
 698
 699 =cut
 700
 701 sub prepare_uploads { }
 702
 703 =item $c->run
 704
 705 Starts the engine.
 706
 707 =cut
 708
 709 sub run { }
 710
 711 =item $c->request
 712
 713 =item $c->req
 714
 715 Returns a C<Catalyst::Request> object.
 716
 717     my $req = $c->req;
 718
 719 =item $c->response
 720
 721 =item $c->res
 722
 723 Returns a C<Catalyst::Response> object.
 724
 725     my $res = $c->res;
 726
 727 =item $c->set_action( $action, $code, $namespace, $attrs )
 728
 729 Set an action in a given namespace.
 730
 731 =cut
 732
 733 sub set_action {
 734     my ( $c, $method, $code, $namespace, $attrs ) = @_;
 735
 736     my $prefix = _class2prefix($namespace) || '';
 737     my %flags;
 738
 739     for my $attr ( @{$attrs} ) {
 740         if    ( $attr =~ /^(Local|Relative)$/ )        { $flags{local}++ }
 741         elsif ( $attr =~ /^(Global|Absolute)$/ )       { $flags{global}++ }
 742         elsif ( $attr =~ /^Path\((.+)\)$/i )           { $flags{path} = $1 }
 743         elsif ( $attr =~ /^Private$/i )                { $flags{private}++ }
 744         elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
 745     }
 746
 747     return unless keys %flags;
 748
 749     my $parent  = $c->tree;
 750     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 751     for my $part ( split '/', $prefix ) {
 752         $visitor->setSearchPath($part);
 753         $parent->accept($visitor);
 754         my $child = $visitor->getResult;
 755         unless ($child) {
 756             $child = $parent->addChild( Tree::Simple->new($part) );
 757             $visitor->setSearchPath($part);
 758             $parent->accept($visitor);
 759             $child = $visitor->getResult;
 760         }
 761         $parent = $child;
 762     }
 763     my $uid = $parent->getUID;
 764     $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
 765     my $forward = $prefix ? "$prefix/$method" : $method;
 766
 767     if ( $flags{path} ) {
 768         $flags{path} =~ s/^\w+//;
 769         $flags{path} =~ s/\w+$//;
 770         if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
 771         if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
 772     }
 773     if ( $flags{regex} ) {
 774         $flags{regex} =~ s/^\w+//;
 775         $flags{regex} =~ s/\w+$//;
 776         if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
 777         if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
 778     }
 779
 780     my $reverse = $prefix ? "$prefix/$method" : $method;
 781
 782     if ( $flags{local} || $flags{global} || $flags{path} ) {
 783         my $path = $flags{path} || $method;
 784         my $absolute = 0;
 785         if ( $path =~ /^\/(.+)/ ) {
 786             $path     = $1;
 787             $absolute = 1;
 788         }
 789         $absolute = 1 if $flags{global};
 790         my $name = $absolute ? $path : $prefix ? "$prefix/$path" : $path;
 791         $c->actions->{plain}->{$name} = [ $namespace, $code ];
 792     }
 793     if ( my $regex = $flags{regex} ) {
 794         push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
 795         $c->actions->{regex}->{$regex} = [ $namespace, $code ];
 796     }
 797
 798     $c->actions->{reverse}->{"$code"} = $reverse;
 799 }
 800
 801 =item $class->setup
 802
 803 Setup.
 804
 805     MyApp->setup;
 806
 807 =cut
 808
 809 sub setup {
 810     my $self = shift;
 811     $self->setup_components;
 812     if ( $self->debug ) {
 813         my $name = $self->config->{name} || 'Application';
 814         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 815     }
 816 }
 817
 818 =item $class->setup_actions($component)
 819
 820 Setup actions for a component.
 821
 822 =cut
 823
 824 sub setup_actions {
 825     my ( $self, $comp ) = @_;
 826     $comp = ref $comp || $comp;
 827     for my $action ( @{ $comp->_cache } ) {
 828         my ( $code, $attrs ) = @{$action};
 829         my $name = '';
 830         no strict 'refs';
 831         my @cache = ( $comp, @{"$comp\::ISA"} );
 832         my %namespaces;
 833         while ( my $namespace = shift @cache ) {
 834             $namespaces{$namespace}++;
 835             for my $isa ( @{"$comp\::ISA"} ) {
 836                 next if $namespaces{$isa};
 837                 push @cache, $isa;
 838                 $namespaces{$isa}++;
 839             }
 840         }
 841         for my $namespace ( keys %namespaces ) {
 842             for my $sym ( values %{ $namespace . '::' } ) {
 843                 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
 844                     $name = *{$sym}{NAME};
 845                     $self->set_action( $name, $code, $comp, $attrs );
 846                     last;
 847                 }
 848             }
 849         }
 850     }
 851 }
 852
 853 =item $class->setup_components
 854
 855 Setup components.
 856
 857 =cut
 858
 859 sub setup_components {
 860     my $self = shift;
 861
 862     # Components
 863     my $class = ref $self || $self;
 864     eval <<"";
 865         package $class;
 866         import Module::Pluggable::Fast
 867           name   => '_components',
 868           search => [
 869             '$class\::Controller', '$class\::C',
 870             '$class\::Model',      '$class\::M',
 871             '$class\::View',       '$class\::V'
 872           ];
 873
 874     if ( my $error = $@ ) {
 875         chomp $error;
 876         $self->log->error(
 877             qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
 878     }
 879     $self->setup_actions($self);
 880     $self->components( {} );
 881     for my $comp ( $self->_components($self) ) {
 882         $self->components->{ ref $comp } = $comp;
 883         $self->setup_actions($comp);
 884     }
 885     my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
 886     $t->setCols('Class');
 887     $t->setColWidth( 'Class', 75, 1 );
 888     $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
 889     $self->log->debug( 'Loaded components', $t->draw )
 890       if ( @{ $t->{tbl_rows} } && $self->debug );
 891     my $actions  = $self->actions;
 892     my $privates = Text::ASCIITable->new;
 893     $privates->setCols( 'Private', 'Class', 'Code' );
 894     $privates->setColWidth( 'Private', 28, 1 );
 895     $privates->setColWidth( 'Class',   28, 1 );
 896     $privates->setColWidth( 'Code',    14, 1 );
 897     my $walker = sub {
 898         my ( $walker, $parent, $prefix ) = @_;
 899         $prefix .= $parent->getNodeValue || '';
 900         $prefix .= '/' unless $prefix =~ /\/$/;
 901         my $uid = $parent->getUID;
 902         for my $action ( keys %{ $actions->{private}->{$uid} } ) {
 903             my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
 904             $privates->addRow(
 905                 wrap( "$prefix$action", 28 ),
 906                 wrap( $class,           28 ),
 907                 wrap( $code,            14 )
 908             );
 909         }
 910         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 911     };
 912     $walker->( $walker, $self->tree, '' );
 913     $self->log->debug( 'Loaded private actions', $privates->draw )
 914       if ( @{ $privates->{tbl_rows} } && $self->debug );
 915     my $publics = Text::ASCIITable->new;
 916     $publics->setCols( 'Public', 'Private' );
 917     $publics->setColWidth( 'Public',  37, 1 );
 918     $publics->setColWidth( 'Private', 36, 1 );
 919
 920     for my $plain ( sort keys %{ $actions->{plain} } ) {
 921         my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
 922         $publics->addRow( wrap( "/$plain", 37 ),
 923             wrap( $self->actions->{reverse}->{$code} || $code, 36 ) );
 924     }
 925     $self->log->debug( 'Loaded public actions', $publics->draw )
 926       if ( @{ $publics->{tbl_rows} } && $self->debug );
 927     my $regexes = Text::ASCIITable->new;
 928     $regexes->setCols( 'Regex', 'Private' );
 929     $regexes->setColWidth( 'Regex',   37, 1 );
 930     $regexes->setColWidth( 'Private', 36, 1 );
 931     for my $regex ( sort keys %{ $actions->{regex} } ) {
 932         my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
 933         $regexes->addRow( wrap( $regex, 37 ),
 934             wrap( $self->actions->{reverse}->{$class} || $class, 36 ) );
 935     }
 936     $self->log->debug( 'Loaded regex actions', $regexes->draw )
 937       if ( @{ $regexes->{tbl_rows} } && $self->debug );
 938 }
 939
 940 =item $c->state
 941
 942 Contains the return value of the last executed action.
 943
 944 =item $c->stash
 945
 946 Returns a hashref containing all your data.
 947
 948     $c->stash->{foo} ||= 'yada';
 949     print $c->stash->{foo};
 950
 951 =cut
 952
 953 sub stash {
 954     my $self = shift;
 955     if ( $_[0] ) {
 956         my $stash = $_[1] ? {@_} : $_[0];
 957         while ( my ( $key, $val ) = each %$stash ) {
 958             $self->{stash}->{$key} = $val;
 959         }
 960     }
 961     return $self->{stash};
 962 }
 963
 964 sub _prefix {
 965     my ( $class, $name ) = @_;
 966     my $prefix = _class2prefix($class);
 967     $name = "$prefix/$name" if $prefix;
 968     return $name;
 969 }
 970
 971 sub _class2prefix {
 972     my $class = shift || '';
 973     my $prefix;
 974     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
 975         $prefix = lc $2;
 976         $prefix =~ s/\:\:/\//g;
 977     }
 978     return $prefix;
 979 }
 980
 981 =back
 982
 983 =head1 AUTHOR
 984
 985 Sebastian Riedel, C<sri@cpan.org>
 986
 987 =head1 COPYRIGHT
 988
 989 This program is free software, you can redistribute it and/or modify it under
 990 the same terms as Perl itself.
 991
 992 =cut
 993
 994 1;