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 ( @{ $c->get_action( $action, $default ) }[-1] )
 463                 {
 464                     $c->state( $c->execute( @{ $result->[0] } ) );
 465                     last unless $default;
 466                 }
 467                 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
 468                 {
 469                     $c->state( $c->execute( @{ $end->[0] } ) );
 470                 }
 471             }
 472             else {
 473                 my $path  = $c->req->path;
 474                 my $error = $path
 475                   ? qq/Unknown resource "$path"/
 476                   : "No default action defined";
 477                 $c->log->error($error) if $c->debug;
 478                 $c->error($error);
 479             }
 480             return $c->finalize;
 481         };
 482         if ( $class->debug ) {
 483             my $elapsed;
 484             ( $elapsed, $status ) = $class->benchmark($handler);
 485             $elapsed = sprintf '%f', $elapsed;
 486             my $av = sprintf '%.3f', 1 / $elapsed;
 487             my $t = Text::ASCIITable->new;
 488             $t->setCols( 'Action', 'Time' );
 489             for my $stat (@stats) {
 490                 $t->addRow(@$stat);
 491             }
 492             $class->log->info( "Request took $elapsed" . "s ($av/s)",
 493                 $t->draw );
 494         }
 495         else { $status = &$handler }
 496     };
 497     if ( my $error = $@ ) {
 498         chomp $error;
 499         $class->log->error(qq/Caught exception in engine "$error"/);
 500     }
 501     $COUNT++;
 502     return $status;
 503 }
 504
 505 =item $c->prepare($r)
 506
 507 Turns the engine-specific request( Apache, CGI ... )
 508 into a Catalyst context .
 509
 510 =cut
 511
 512 sub prepare {
 513     my ( $class, $r ) = @_;
 514     my $c = bless {
 515         request => Catalyst::Request->new(
 516             {
 517                 arguments  => [],
 518                 cookies    => {},
 519                 headers    => HTTP::Headers->new,
 520                 parameters => {},
 521                 snippets   => [],
 522                 uploads    => {}
 523             }
 524         ),
 525         response => Catalyst::Response->new(
 526             { cookies => {}, headers => HTTP::Headers->new, status => 200 }
 527         ),
 528         stash => {},
 529         state => 0
 530     }, $class;
 531     if ( $c->debug ) {
 532         my $secs = time - $START || 1;
 533         my $av = sprintf '%.3f', $COUNT / $secs;
 534         $c->log->debug('********************************');
 535         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 536         $c->log->debug('********************************');
 537         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 538     }
 539     $c->prepare_request($r);
 540     $c->prepare_path;
 541     $c->prepare_headers;
 542     $c->prepare_cookies;
 543     $c->prepare_connection;
 544     my $method   = $c->req->method   || '';
 545     my $path     = $c->req->path     || '';
 546     my $hostname = $c->req->hostname || '';
 547     my $address  = $c->req->address  || '';
 548     $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
 549       if $c->debug;
 550     $c->prepare_action;
 551     $c->prepare_parameters;
 552
 553     if ( $c->debug && keys %{ $c->req->params } ) {
 554         my $t = Text::ASCIITable->new;
 555         $t->setCols( 'Key', 'Value' );
 556         for my $key ( keys %{ $c->req->params } ) {
 557             my $value = $c->req->params->{$key} || '';
 558             $t->addRow( $key, $value );
 559         }
 560         $c->log->debug( 'Parameters are', $t->draw );
 561     }
 562     $c->prepare_uploads;
 563     return $c;
 564 }
 565
 566 =item $c->prepare_action
 567
 568 Prepare action.
 569
 570 =cut
 571
 572 sub prepare_action {
 573     my $c    = shift;
 574     my $path = $c->req->path;
 575     my @path = split /\//, $c->req->path;
 576     $c->req->args( \my @args );
 577     while (@path) {
 578         $path = join '/', @path;
 579         if ( my $result = ${ $c->get_action($path) }[0] ) {
 580
 581             # It's a regex
 582             if ($#$result) {
 583                 my $match    = $result->[1];
 584                 my @snippets = @{ $result->[2] };
 585                 $c->log->debug(qq/Requested action "$path" matched "$match"/)
 586                   if $c->debug;
 587                 $c->log->debug(
 588                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 589                   if ( $c->debug && @snippets );
 590                 $c->req->action($match);
 591                 $c->req->snippets( \@snippets );
 592             }
 593             else {
 594                 $c->req->action($path);
 595                 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
 596             }
 597             $c->req->match($path);
 598             last;
 599         }
 600         unshift @args, pop @path;
 601     }
 602     unless ( $c->req->action ) {
 603         $c->req->action('default');
 604         $c->req->match('');
 605     }
 606     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 607       if ( $c->debug && @args );
 608 }
 609
 610 =item $c->prepare_connection
 611
 612 Prepare connection.
 613
 614 =cut
 615
 616 sub prepare_connection { }
 617
 618 =item $c->prepare_cookies
 619
 620 Prepare cookies.
 621
 622 =cut
 623
 624 sub prepare_cookies {
 625     my $c = shift;
 626
 627     if ( my $header = $c->request->header('Cookie') ) {
 628         $c->req->cookies( { CGI::Cookie->parse($header) } );
 629     }
 630 }
 631
 632 =item $c->prepare_headers
 633
 634 Prepare headers.
 635
 636 =cut
 637
 638 sub prepare_headers { }
 639
 640 =item $c->prepare_parameters
 641
 642 Prepare parameters.
 643
 644 =cut
 645
 646 sub prepare_parameters { }
 647
 648 =item $c->prepare_path
 649
 650 Prepare path and base.
 651
 652 =cut
 653
 654 sub prepare_path { }
 655
 656 =item $c->prepare_request
 657
 658 Prepare the engine request.
 659
 660 =cut
 661
 662 sub prepare_request { }
 663
 664 =item $c->prepare_uploads
 665
 666 Prepare uploads.
 667
 668 =cut
 669
 670 sub prepare_uploads { }
 671
 672 =item $c->run
 673
 674 Starts the engine.
 675
 676 =cut
 677
 678 sub run { }
 679
 680 =item $c->request
 681
 682 =item $c->req
 683
 684 Returns a C<Catalyst::Request> object.
 685
 686     my $req = $c->req;
 687
 688 =item $c->response
 689
 690 =item $c->res
 691
 692 Returns a C<Catalyst::Response> object.
 693
 694     my $res = $c->res;
 695
 696 =item $c->set_action( $action, $code, $namespace, $attrs )
 697
 698 Set an action in a given namespace.
 699
 700 =cut
 701
 702 sub set_action {
 703     my ( $c, $method, $code, $namespace, $attrs ) = @_;
 704
 705     my $prefix = _class2prefix($namespace) || '';
 706     my %flags;
 707
 708     for my $attr ( @{$attrs} ) {
 709         if    ( $attr =~ /^(Local|Relative)$/ )        { $flags{local}++ }
 710         elsif ( $attr =~ /^(Global|Absolute)$/ )       { $flags{global}++ }
 711         elsif ( $attr =~ /^Path\((.+)\)$/i )           { $flags{path} = $1 }
 712         elsif ( $attr =~ /^Private$/i )                { $flags{private}++ }
 713         elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
 714     }
 715
 716     return unless keys %flags;
 717
 718     my $parent  = $c->tree;
 719     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 720     for my $part ( split '/', $prefix ) {
 721         $visitor->setSearchPath($part);
 722         $parent->accept($visitor);
 723         my $child = $visitor->getResult;
 724         unless ($child) {
 725             $child = $parent->addChild( Tree::Simple->new($part) );
 726             $visitor->setSearchPath($part);
 727             $parent->accept($visitor);
 728             $child = $visitor->getResult;
 729         }
 730         $parent = $child;
 731     }
 732     my $uid = $parent->getUID;
 733     $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
 734     my $forward = $prefix ? "$prefix/$method" : $method;
 735
 736     if ( $flags{path} ) {
 737         $flags{path} =~ s/^\w+//;
 738         $flags{path} =~ s/\w+$//;
 739         if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
 740         if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
 741     }
 742     if ( $flags{regex} ) {
 743         $flags{regex} =~ s/^\w+//;
 744         $flags{regex} =~ s/\w+$//;
 745         if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
 746         if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
 747     }
 748
 749     my $reverse = $prefix ? "$prefix/$method" : $method;
 750
 751     if ( $flags{local} || $flags{global} || $flags{path} ) {
 752         my $path = $flags{path} || $method;
 753         my $absolute = 0;
 754         if ( $path =~ /^\/(.+)/ ) {
 755             $path     = $1;
 756             $absolute = 1;
 757         }
 758         $absolute = 1 if $flags{global};
 759         my $name = $absolute ? $path : "$prefix/$path";
 760         $c->actions->{plain}->{$name} = [ $namespace, $code ];
 761     }
 762     if ( my $regex = $flags{regex} ) {
 763         push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
 764         $c->actions->{regex}->{$regex} = [ $namespace, $code ];
 765     }
 766
 767     $c->actions->{reverse}->{"$code"} = $reverse;
 768 }
 769
 770 =item $class->setup
 771
 772 Setup.
 773
 774     MyApp->setup;
 775
 776 =cut
 777
 778 sub setup {
 779     my $self = shift;
 780     $self->setup_components;
 781     if ( $self->debug ) {
 782         my $name = $self->config->{name} || 'Application';
 783         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 784     }
 785 }
 786
 787 =item $class->setup_actions($component)
 788
 789 Setup actions for a component.
 790
 791 =cut
 792
 793 sub setup_actions {
 794     my ( $self, $comp ) = @_;
 795     $comp = ref $comp || $comp;
 796     for my $action ( @{ $comp->_cache } ) {
 797         my ( $code, $attrs ) = @{$action};
 798         my $name = '';
 799         no strict 'refs';
 800         my @cache = ( $comp, @{"$comp\::ISA"} );
 801         my %namespaces;
 802         while ( my $namespace = shift @cache ) {
 803             $namespaces{$namespace}++;
 804             for my $isa ( @{"$comp\::ISA"} ) {
 805                 next if $namespaces{$isa};
 806                 push @cache, $isa;
 807                 $namespaces{$isa}++;
 808             }
 809         }
 810         for my $namespace ( keys %namespaces ) {
 811             for my $sym ( values %{ $namespace . '::' } ) {
 812                 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
 813                     $name = *{$sym}{NAME};
 814                     $self->set_action( $name, $code, $comp, $attrs );
 815                     last;
 816                 }
 817             }
 818         }
 819     }
 820 }
 821
 822 =item $class->setup_components
 823
 824 Setup components.
 825
 826 =cut
 827
 828 sub setup_components {
 829     my $self = shift;
 830
 831     # Components
 832     my $class = ref $self || $self;
 833     eval <<"";
 834         package $class;
 835         import Module::Pluggable::Fast
 836           name   => '_components',
 837           search => [
 838             '$class\::Controller', '$class\::C',
 839             '$class\::Model',      '$class\::M',
 840             '$class\::View',       '$class\::V'
 841           ];
 842
 843     if ( my $error = $@ ) {
 844         chomp $error;
 845         $self->log->error(
 846             qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
 847     }
 848     $self->setup_actions($self);
 849     $self->components( {} );
 850     for my $comp ( $self->_components($self) ) {
 851         $self->components->{ ref $comp } = $comp;
 852         $self->setup_actions($comp);
 853     }
 854     my $t = Text::ASCIITable->new;
 855     $t->setCols('Class');
 856     $t->addRow($_) for keys %{ $self->components };
 857     $self->log->debug( 'Loaded components', $t->draw )
 858       if ( @{ $t->{tbl_rows} } && $self->debug );
 859     my $actions  = $self->actions;
 860     my $privates = Text::ASCIITable->new;
 861     $privates->setCols( 'Action', 'Class', 'Code' );
 862     my $walker = sub {
 863         my ( $walker, $parent, $prefix ) = @_;
 864         $prefix .= $parent->getNodeValue || '';
 865         $prefix .= '/' unless $prefix =~ /\/$/;
 866         my $uid = $parent->getUID;
 867         for my $action ( keys %{ $actions->{private}->{$uid} } ) {
 868             my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
 869             $privates->addRow( "$prefix$action", $class, $code );
 870         }
 871         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 872     };
 873     $walker->( $walker, $self->tree, '' );
 874     $self->log->debug( 'Loaded private actions', $privates->draw )
 875       if ( @{ $privates->{tbl_rows} } && $self->debug );
 876     my $publics = Text::ASCIITable->new;
 877     $publics->setCols( 'Action', 'Class', 'Code' );
 878     for my $plain ( sort keys %{ $actions->{plain} } ) {
 879         my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
 880         $publics->addRow( "/$plain", $class, $code );
 881     }
 882     $self->log->debug( 'Loaded public actions', $publics->draw )
 883       if ( @{ $publics->{tbl_rows} } && $self->debug );
 884     my $regexes = Text::ASCIITable->new;
 885     $regexes->setCols( 'Action', 'Class', 'Code' );
 886     for my $regex ( sort keys %{ $actions->{regex} } ) {
 887         my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
 888         $regexes->addRow( $regex, $class, $code );
 889     }
 890     $self->log->debug( 'Loaded regex actions', $regexes->draw )
 891       if ( @{ $regexes->{tbl_rows} } && $self->debug );
 892 }
 893
 894 =item $c->stash
 895
 896 Returns a hashref containing all your data.
 897
 898     $c->stash->{foo} ||= 'yada';
 899     print $c->stash->{foo};
 900
 901 =cut
 902
 903 sub stash {
 904     my $self = shift;
 905     if ( $_[0] ) {
 906         my $stash = $_[1] ? {@_} : $_[0];
 907         while ( my ( $key, $val ) = each %$stash ) {
 908             $self->{stash}->{$key} = $val;
 909         }
 910     }
 911     return $self->{stash};
 912 }
 913
 914 sub _prefix {
 915     my ( $class, $name ) = @_;
 916     my $prefix = _class2prefix($class);
 917     $name = "$prefix/$name" if $prefix;
 918     return $name;
 919 }
 920
 921 sub _class2prefix {
 922     my $class = shift || '';
 923     my $prefix;
 924     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
 925         $prefix = lc $2;
 926         $prefix =~ s/\:\:/\//g;
 927     }
 928     return $prefix;
 929 }
 930
 931 sub _prettify_action {
 932     my ( $val1, $val2, $val3 ) = @_;
 933     formline '  + @<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<'
 934       . ' @>>>>>>>>>>>>>>  ', $val1, $val2, $val3;
 935     my $formatted = $^A;
 936     $^A = '';
 937     return $formatted;
 938 }
 939
 940 sub _prettify_stats {
 941     my ( $val1, $val2 ) = @_;
 942     formline '  + @<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ',
 943       $val1, $val2;
 944     my $formatted = $^A;
 945     $^A = '';
 946     return $formatted;
 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;