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