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