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