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