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