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