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 @stats = ();
 361         my $handler = sub {
 362             my $c = $class->prepare($r);
 363             $c->{stats} = \@stats;
 364             my $action    = $c->req->action;
 365             my $namespace = '';
 366             $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
 367               if $action eq 'default';
 368             unless ($namespace) {
 369                 if ( my $result = $c->get_action($action) ) {
 370                     $namespace = _class2prefix( $result->[0]->[0]->[0] );
 371                 }
 372             }
 373             my $default = $action eq 'default' ? $namespace : undef;
 374             my $results = $c->get_action( $action, $default );
 375             $namespace ||= '/';
 376             if ( @{$results} ) {
 377                 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
 378                     $c->state( $c->execute( @{ $begin->[0] } ) );
 379                 }
 380                 for my $result ( @{ $c->get_action( $action, $default ) }[-1] )
 381                 {
 382                     $c->state( $c->execute( @{ $result->[0] } ) );
 383                     last unless $default;
 384                 }
 385                 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
 386                 {
 387                     $c->state( $c->execute( @{ $end->[0] } ) );
 388                 }
 389             }
 390             else {
 391                 my $path  = $c->req->path;
 392                 my $error = $path
 393                   ? qq/Unknown resource "$path"/
 394                   : "No default action defined";
 395                 $c->log->error($error) if $c->debug;
 396                 $c->error($error);
 397             }
 398             return $c->finalize;
 399         };
 400         if ( $class->debug ) {
 401             my $elapsed;
 402             ( $elapsed, $status ) = $class->benchmark($handler);
 403             $elapsed = sprintf '%f', $elapsed;
 404             my $av = sprintf '%.3f', 1 / $elapsed;
 405             $class->log->info( "Request took $elapsed" . "s ($av/s)", @stats );
 406         }
 407         else { $status = &$handler }
 408     };
 409     if ( my $error = $@ ) {
 410         chomp $error;
 411         $class->log->error(qq/Caught exception in engine "$error"/);
 412     }
 413     $COUNT++;
 414     return $status;
 415 }
 416
 417 =item $c->prepare($r)
 418
 419 Turns the engine-specific request( Apache, CGI ... )
 420 into a Catalyst context .
 421
 422 =cut
 423
 424 sub prepare {
 425     my ( $class, $r ) = @_;
 426     my $c = bless {
 427         request => Catalyst::Request->new(
 428             {
 429                 arguments  => [],
 430                 cookies    => {},
 431                 headers    => HTTP::Headers->new,
 432                 parameters => {},
 433                 snippets   => [],
 434                 uploads    => {}
 435             }
 436         ),
 437         response => Catalyst::Response->new(
 438             { cookies => {}, headers => HTTP::Headers->new, status => 200 }
 439         ),
 440         stash => {},
 441         state => 0
 442     }, $class;
 443     if ( $c->debug ) {
 444         my $secs = time - $START || 1;
 445         my $av = sprintf '%.3f', $COUNT / $secs;
 446         $c->log->debug('********************************');
 447         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 448         $c->log->debug('********************************');
 449         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 450     }
 451     $c->prepare_request($r);
 452     $c->prepare_path;
 453     $c->prepare_headers;
 454     $c->prepare_cookies;
 455     $c->prepare_connection;
 456     my $method   = $c->req->method   || '';
 457     my $path     = $c->req->path     || '';
 458     my $hostname = $c->req->hostname || '';
 459     my $address  = $c->req->address  || '';
 460     $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
 461       if $c->debug;
 462     $c->prepare_action;
 463     $c->prepare_parameters;
 464
 465     if ( $c->debug && keys %{ $c->req->params } ) {
 466         my @params;
 467         for my $key ( keys %{ $c->req->params } ) {
 468             my $value = $c->req->params->{$key} || '';
 469             push @params, "  $key=$value";
 470         }
 471         $c->log->debug( 'Parameters are', @params );
 472     }
 473     $c->prepare_uploads;
 474     return $c;
 475 }
 476
 477 =item $c->prepare_action
 478
 479 Prepare action.
 480
 481 =cut
 482
 483 sub prepare_action {
 484     my $c    = shift;
 485     my $path = $c->req->path;
 486     my @path = split /\//, $c->req->path;
 487     $c->req->args( \my @args );
 488     while (@path) {
 489         $path = join '/', @path;
 490         if ( my $result = ${ $c->get_action($path) }[0] ) {
 491
 492             # It's a regex
 493             if ($#$result) {
 494                 my $match    = $result->[1];
 495                 my @snippets = @{ $result->[2] };
 496                 $c->log->debug(qq/Requested action "$path" matched "$match"/)
 497                   if $c->debug;
 498                 $c->log->debug(
 499                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 500                   if ( $c->debug && @snippets );
 501                 $c->req->action($match);
 502                 $c->req->snippets( \@snippets );
 503             }
 504             else {
 505                 $c->req->action($path);
 506                 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
 507             }
 508             $c->req->match($path);
 509             last;
 510         }
 511         unshift @args, pop @path;
 512     }
 513     unless ( $c->req->action ) {
 514         $c->req->action('default');
 515         $c->req->match('');
 516     }
 517     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 518       if ( $c->debug && @args );
 519 }
 520
 521 =item $c->prepare_connection
 522
 523 Prepare connection.
 524
 525 =cut
 526
 527 sub prepare_connection { }
 528
 529 =item $c->prepare_cookies
 530
 531 Prepare cookies.
 532
 533 =cut
 534
 535 sub prepare_cookies { }
 536
 537 =item $c->prepare_headers
 538
 539 Prepare headers.
 540
 541 =cut
 542
 543 sub prepare_headers { }
 544
 545 =item $c->prepare_parameters
 546
 547 Prepare parameters.
 548
 549 =cut
 550
 551 sub prepare_parameters { }
 552
 553 =item $c->prepare_path
 554
 555 Prepare path and base.
 556
 557 =cut
 558
 559 sub prepare_path { }
 560
 561 =item $c->prepare_request
 562
 563 Prepare the engine request.
 564
 565 =cut
 566
 567 sub prepare_request { }
 568
 569 =item $c->prepare_uploads
 570
 571 Prepare uploads.
 572
 573 =cut
 574
 575 sub prepare_uploads { }
 576
 577 =item $c->execute($class, $coderef)
 578
 579 Execute a coderef in given class and catch exceptions.
 580 Errors are available via $c->error.
 581
 582 =cut
 583
 584 sub execute {
 585     my ( $c, $class, $code ) = @_;
 586     $class = $c->comp($class) || $class;
 587     $c->state(0);
 588     eval {
 589         if ( $c->debug )
 590         {
 591             my $action = $c->actions->{reverse}->{"$code"};
 592             $action = "/$action" unless $action =~ /\-\>/;
 593             my ( $elapsed, @state ) =
 594               $c->benchmark( $code, $class, $c, @{ $c->req->args } );
 595             push @{ $c->{stats} },
 596               _prettify( $action, sprintf( '%fs', $elapsed ), '' );
 597             $c->state(@state);
 598         }
 599         else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
 600     };
 601     if ( my $error = $@ ) {
 602         chomp $error;
 603         $error = qq/Caught exception "$error"/;
 604         $c->log->error($error);
 605         $c->error($error) if $c->debug;
 606         $c->state(0);
 607     }
 608     return $c->state;
 609 }
 610
 611 =item $c->run
 612
 613 Starts the engine.
 614
 615 =cut
 616
 617 sub run { }
 618
 619 =item $c->request
 620
 621 =item $c->req
 622
 623 Returns a C<Catalyst::Request> object.
 624
 625     my $req = $c->req;
 626
 627 =item $c->response
 628
 629 =item $c->res
 630
 631 Returns a C<Catalyst::Response> object.
 632
 633     my $res = $c->res;
 634
 635 =item $c->set_action( $action, $code, $namespace, $attrs )
 636
 637 Set an action in a given namespace.
 638
 639 =cut
 640
 641 sub set_action {
 642     my ( $c, $method, $code, $namespace, $attrs ) = @_;
 643
 644     my $prefix = _class2prefix($namespace) || '';
 645     my %flags;
 646
 647     for my $attr ( @{$attrs} ) {
 648         if    ( $attr =~ /^(Local|Relative)$/ )        { $flags{local}++ }
 649         elsif ( $attr =~ /^(Global|Absolute)$/ )       { $flags{global}++ }
 650         elsif ( $attr =~ /^Path\((.+)\)$/i )           { $flags{path} = $1 }
 651         elsif ( $attr =~ /^Private$/i )                { $flags{private}++ }
 652         elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
 653     }
 654
 655     return unless keys %flags;
 656
 657     my $parent  = $c->tree;
 658     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 659     for my $part ( split '/', $prefix ) {
 660         $visitor->setSearchPath($part);
 661         $parent->accept($visitor);
 662         my $child = $visitor->getResult;
 663         unless ($child) {
 664             $child = $parent->addChild( Tree::Simple->new($part) );
 665             $visitor->setSearchPath($part);
 666             $parent->accept($visitor);
 667             $child = $visitor->getResult;
 668         }
 669         $parent = $child;
 670     }
 671     my $uid = $parent->getUID;
 672     $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
 673     my $forward = $prefix ? "$prefix/$method" : $method;
 674
 675     if ( $flags{path} ) {
 676         $flags{path} =~ s/^\w+//;
 677         $flags{path} =~ s/\w+$//;
 678         if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
 679         if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
 680     }
 681     if ( $flags{regex} ) {
 682         $flags{regex} =~ s/^\w+//;
 683         $flags{regex} =~ s/\w+$//;
 684         if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
 685         if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
 686     }
 687
 688     my $reverse = $prefix ? "$prefix/$method" : $method;
 689
 690     if ( $flags{local} || $flags{global} || $flags{path} ) {
 691         my $path = $flags{path} || $method;
 692         my $absolute = 0;
 693         if ( $path =~ /^\/(.+)/ ) {
 694             $path     = $1;
 695             $absolute = 1;
 696         }
 697         $absolute = 1 if $flags{global};
 698         my $name = $absolute ? $path : "$prefix/$path";
 699         $c->actions->{plain}->{$name} = [ $namespace, $code ];
 700     }
 701     if ( my $regex = $flags{regex} ) {
 702         push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
 703         $c->actions->{regex}->{$regex} = [ $namespace, $code ];
 704     }
 705
 706     $c->actions->{reverse}->{"$code"} = $reverse;
 707 }
 708
 709 =item $class->setup
 710
 711 Setup.
 712
 713     MyApp->setup;
 714
 715 =cut
 716
 717 sub setup {
 718     my $self = shift;
 719     $self->setup_components;
 720     if ( $self->debug ) {
 721         my $name = $self->config->{name} || 'Application';
 722         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 723     }
 724 }
 725
 726 =item $class->setup_actions($component)
 727
 728 Setup actions for a component.
 729
 730 =cut
 731
 732 sub setup_actions {
 733     my ( $self, $comp ) = @_;
 734     $comp = ref $comp || $comp;
 735     for my $action ( @{ $comp->_cache } ) {
 736         my ( $code, $attrs ) = @{$action};
 737         my $name = '';
 738         no strict 'refs';
 739         my @cache = ( $comp, @{"$comp\::ISA"} );
 740         my %namespaces;
 741         while ( my $namespace = shift @cache ) {
 742             $namespaces{$namespace}++;
 743             for my $isa ( @{"$comp\::ISA"} ) {
 744                 next if $namespaces{$isa};
 745                 push @cache, $isa;
 746                 $namespaces{$isa}++;
 747             }
 748         }
 749         for my $namespace ( keys %namespaces ) {
 750             for my $sym ( values %{ $namespace . '::' } ) {
 751                 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
 752                     $name = *{$sym}{NAME};
 753                     $self->set_action( $name, $code, $comp, $attrs );
 754                     last;
 755                 }
 756             }
 757         }
 758     }
 759 }
 760
 761 =item $class->setup_components
 762
 763 Setup components.
 764
 765 =cut
 766
 767 sub setup_components {
 768     my $self = shift;
 769
 770     # Components
 771     my $class = ref $self || $self;
 772     eval <<"";
 773         package $class;
 774         import Module::Pluggable::Fast
 775           name   => '_components',
 776           search => [
 777             '$class\::Controller', '$class\::C',
 778             '$class\::Model',      '$class\::M',
 779             '$class\::View',       '$class\::V'
 780           ];
 781
 782     if ( my $error = $@ ) {
 783         chomp $error;
 784         $self->log->error(
 785             qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
 786     }
 787     $self->setup_actions($self);
 788     $self->components( {} );
 789     for my $comp ( $self->_components($self) ) {
 790         $self->components->{ ref $comp } = $comp;
 791         $self->setup_actions($comp);
 792     }
 793     my @comps;
 794     push @comps, "  $_" for keys %{ $self->components };
 795     $self->log->debug( 'Loaded components', @comps )
 796       if ( @comps && $self->debug );
 797     my $actions  = $self->actions;
 798     my @messages = ('Loaded private actions');
 799     my $walker   = sub {
 800         my ( $walker, $parent, $messages, $prefix ) = @_;
 801         $prefix .= $parent->getNodeValue || '';
 802         $prefix .= '/' unless $prefix =~ /\/$/;
 803         my $uid = $parent->getUID;
 804         for my $action ( keys %{ $actions->{private}->{$uid} } ) {
 805             my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
 806             push @$messages, _prettify( "$prefix$action", $class, $code );
 807         }
 808         $walker->( $walker, $_, $messages, $prefix )
 809           for $parent->getAllChildren;
 810     };
 811     $walker->( $walker, $self->tree, \@messages, '' );
 812     $self->log->debug(@messages) if ( $#messages && $self->debug );
 813     @messages = ('Loaded plain actions');
 814     for my $plain ( sort keys %{ $actions->{plain} } ) {
 815         my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
 816         push @messages, _prettify( "/$plain", $class, $code );
 817     }
 818     $self->log->debug(@messages) if ( $#messages && $self->debug );
 819     @messages = ('Loaded regex actions');
 820     for my $regex ( sort keys %{ $actions->{regex} } ) {
 821         my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
 822         push @messages, _prettify( $regex, $class, $code );
 823     }
 824     $self->log->debug(@messages) if ( $#messages && $self->debug );
 825 }
 826
 827 =item $c->stash
 828
 829 Returns a hashref containing all your data.
 830
 831     $c->stash->{foo} ||= 'yada';
 832     print $c->stash->{foo};
 833
 834 =cut
 835
 836 sub stash {
 837     my $self = shift;
 838     if ( $_[0] ) {
 839         my $stash = $_[1] ? {@_} : $_[0];
 840         while ( my ( $key, $val ) = each %$stash ) {
 841             $self->{stash}->{$key} = $val;
 842         }
 843     }
 844     return $self->{stash};
 845 }
 846
 847 sub _prefix {
 848     my ( $class, $name ) = @_;
 849     my $prefix = _class2prefix($class);
 850     $name = "$prefix/$name" if $prefix;
 851     return $name;
 852 }
 853
 854 sub _class2prefix {
 855     my $class = shift || '';
 856     my $prefix;
 857     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
 858         $prefix = lc $2;
 859         $prefix =~ s/\:\:/\//g;
 860     }
 861     return $prefix;
 862 }
 863
 864 sub _prettify {
 865     my ( $val1, $val2, $val3 ) = @_;
 866     formline
 867 '  @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>>  ',
 868       $val1, $val2, $val3;
 869     my $formatted = $^A;
 870     $^A = '';
 871     return $formatted;
 872 }
 873
 874 =back
 875
 876 =head1 AUTHOR
 877
 878 Sebastian Riedel, C<sri@cpan.org>
 879
 880 =head1 COPYRIGHT
 881
 882 This program is free software, you can redistribute it and/or modify it under
 883 the same terms as Perl itself.
 884
 885 =cut
 886
 887 1;