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(
 586                     qq/Requested action is "$path" and matched "$match"/)
 587                   if $c->debug;
 588                 $c->log->debug(
 589                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 590                   if ( $c->debug && @snippets );
 591                 $c->req->action($match);
 592                 $c->req->snippets( \@snippets );
 593             }
 594             else {
 595                 $c->req->action($path);
 596                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 597             }
 598             $c->req->match($path);
 599             last;
 600         }
 601         unshift @args, pop @path;
 602     }
 603     unless ( $c->req->action ) {
 604         $c->req->action('default');
 605         $c->req->match('');
 606     }
 607     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 608       if ( $c->debug && @args );
 609 }
 610
 611 =item $c->prepare_connection
 612
 613 Prepare connection.
 614
 615 =cut
 616
 617 sub prepare_connection { }
 618
 619 =item $c->prepare_cookies
 620
 621 Prepare cookies.
 622
 623 =cut
 624
 625 sub prepare_cookies {
 626     my $c = shift;
 627
 628     if ( my $header = $c->request->header('Cookie') ) {
 629         $c->req->cookies( { CGI::Cookie->parse($header) } );
 630     }
 631 }
 632
 633 =item $c->prepare_headers
 634
 635 Prepare headers.
 636
 637 =cut
 638
 639 sub prepare_headers { }
 640
 641 =item $c->prepare_parameters
 642
 643 Prepare parameters.
 644
 645 =cut
 646
 647 sub prepare_parameters { }
 648
 649 =item $c->prepare_path
 650
 651 Prepare path and base.
 652
 653 =cut
 654
 655 sub prepare_path { }
 656
 657 =item $c->prepare_request
 658
 659 Prepare the engine request.
 660
 661 =cut
 662
 663 sub prepare_request { }
 664
 665 =item $c->prepare_uploads
 666
 667 Prepare uploads.
 668
 669 =cut
 670
 671 sub prepare_uploads { }
 672
 673 =item $c->run
 674
 675 Starts the engine.
 676
 677 =cut
 678
 679 sub run { }
 680
 681 =item $c->request
 682
 683 =item $c->req
 684
 685 Returns a C<Catalyst::Request> object.
 686
 687     my $req = $c->req;
 688
 689 =item $c->response
 690
 691 =item $c->res
 692
 693 Returns a C<Catalyst::Response> object.
 694
 695     my $res = $c->res;
 696
 697 =item $c->set_action( $action, $code, $namespace, $attrs )
 698
 699 Set an action in a given namespace.
 700
 701 =cut
 702
 703 sub set_action {
 704     my ( $c, $method, $code, $namespace, $attrs ) = @_;
 705
 706     my $prefix = _class2prefix($namespace) || '';
 707     my %flags;
 708
 709     for my $attr ( @{$attrs} ) {
 710         if    ( $attr =~ /^(Local|Relative)$/ )        { $flags{local}++ }
 711         elsif ( $attr =~ /^(Global|Absolute)$/ )       { $flags{global}++ }
 712         elsif ( $attr =~ /^Path\((.+)\)$/i )           { $flags{path} = $1 }
 713         elsif ( $attr =~ /^Private$/i )                { $flags{private}++ }
 714         elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
 715     }
 716
 717     return unless keys %flags;
 718
 719     my $parent  = $c->tree;
 720     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 721     for my $part ( split '/', $prefix ) {
 722         $visitor->setSearchPath($part);
 723         $parent->accept($visitor);
 724         my $child = $visitor->getResult;
 725         unless ($child) {
 726             $child = $parent->addChild( Tree::Simple->new($part) );
 727             $visitor->setSearchPath($part);
 728             $parent->accept($visitor);
 729             $child = $visitor->getResult;
 730         }
 731         $parent = $child;
 732     }
 733     my $uid = $parent->getUID;
 734     $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
 735     my $forward = $prefix ? "$prefix/$method" : $method;
 736
 737     if ( $flags{path} ) {
 738         $flags{path} =~ s/^\w+//;
 739         $flags{path} =~ s/\w+$//;
 740         if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
 741         if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
 742     }
 743     if ( $flags{regex} ) {
 744         $flags{regex} =~ s/^\w+//;
 745         $flags{regex} =~ s/\w+$//;
 746         if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
 747         if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
 748     }
 749
 750     my $reverse = $prefix ? "$prefix/$method" : $method;
 751
 752     if ( $flags{local} || $flags{global} || $flags{path} ) {
 753         my $path = $flags{path} || $method;
 754         my $absolute = 0;
 755         if ( $path =~ /^\/(.+)/ ) {
 756             $path     = $1;
 757             $absolute = 1;
 758         }
 759         $absolute = 1 if $flags{global};
 760         my $name = $absolute ? $path : "$prefix/$path";
 761         $c->actions->{plain}->{$name} = [ $namespace, $code ];
 762     }
 763     if ( my $regex = $flags{regex} ) {
 764         push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
 765         $c->actions->{regex}->{$regex} = [ $namespace, $code ];
 766     }
 767
 768     $c->actions->{reverse}->{"$code"} = $reverse;
 769 }
 770
 771 =item $class->setup
 772
 773 Setup.
 774
 775     MyApp->setup;
 776
 777 =cut
 778
 779 sub setup {
 780     my $self = shift;
 781     $self->setup_components;
 782     if ( $self->debug ) {
 783         my $name = $self->config->{name} || 'Application';
 784         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 785     }
 786 }
 787
 788 =item $class->setup_actions($component)
 789
 790 Setup actions for a component.
 791
 792 =cut
 793
 794 sub setup_actions {
 795     my ( $self, $comp ) = @_;
 796     $comp = ref $comp || $comp;
 797     for my $action ( @{ $comp->_cache } ) {
 798         my ( $code, $attrs ) = @{$action};
 799         my $name = '';
 800         no strict 'refs';
 801         my @cache = ( $comp, @{"$comp\::ISA"} );
 802         my %namespaces;
 803         while ( my $namespace = shift @cache ) {
 804             $namespaces{$namespace}++;
 805             for my $isa ( @{"$comp\::ISA"} ) {
 806                 next if $namespaces{$isa};
 807                 push @cache, $isa;
 808                 $namespaces{$isa}++;
 809             }
 810         }
 811         for my $namespace ( keys %namespaces ) {
 812             for my $sym ( values %{ $namespace . '::' } ) {
 813                 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
 814                     $name = *{$sym}{NAME};
 815                     $self->set_action( $name, $code, $comp, $attrs );
 816                     last;
 817                 }
 818             }
 819         }
 820     }
 821 }
 822
 823 =item $class->setup_components
 824
 825 Setup components.
 826
 827 =cut
 828
 829 sub setup_components {
 830     my $self = shift;
 831
 832     # Components
 833     my $class = ref $self || $self;
 834     eval <<"";
 835         package $class;
 836         import Module::Pluggable::Fast
 837           name   => '_components',
 838           search => [
 839             '$class\::Controller', '$class\::C',
 840             '$class\::Model',      '$class\::M',
 841             '$class\::View',       '$class\::V'
 842           ];
 843
 844     if ( my $error = $@ ) {
 845         chomp $error;
 846         $self->log->error(
 847             qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
 848     }
 849     $self->setup_actions($self);
 850     $self->components( {} );
 851     for my $comp ( $self->_components($self) ) {
 852         $self->components->{ ref $comp } = $comp;
 853         $self->setup_actions($comp);
 854     }
 855     my $t = Text::ASCIITable->new;
 856     $t->setCols('Class');
 857     $t->addRow($_) for keys %{ $self->components };
 858     $self->log->debug( 'Loaded components', $t->draw )
 859       if ( @{ $t->{tbl_rows} } && $self->debug );
 860     my $actions  = $self->actions;
 861     my $privates = Text::ASCIITable->new;
 862     $privates->setCols( 'Action', 'Class', 'Code' );
 863     my $walker = sub {
 864         my ( $walker, $parent, $prefix ) = @_;
 865         $prefix .= $parent->getNodeValue || '';
 866         $prefix .= '/' unless $prefix =~ /\/$/;
 867         my $uid = $parent->getUID;
 868         for my $action ( keys %{ $actions->{private}->{$uid} } ) {
 869             my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
 870             $privates->addRow( "$prefix$action", $class, $code );
 871         }
 872         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 873     };
 874     $walker->( $walker, $self->tree, '' );
 875     $self->log->debug( 'Loaded private actions', $privates->draw )
 876       if ( @{ $privates->{tbl_rows} } && $self->debug );
 877     my $publics = Text::ASCIITable->new;
 878     $publics->setCols( 'Action', 'Class', 'Code' );
 879     for my $plain ( sort keys %{ $actions->{plain} } ) {
 880         my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
 881         $publics->addRow( "/$plain", $class, $code );
 882     }
 883     $self->log->debug( 'Loaded public actions', $publics->draw )
 884       if ( @{ $publics->{tbl_rows} } && $self->debug );
 885     my $regexes = Text::ASCIITable->new;
 886     $regexes->setCols( 'Action', 'Class', 'Code' );
 887     for my $regex ( sort keys %{ $actions->{regex} } ) {
 888         my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
 889         $regexes->addRow( $regex, $class, $code );
 890     }
 891     $self->log->debug( 'Loaded regex actions', $regexes->draw )
 892       if ( @{ $regexes->{tbl_rows} } && $self->debug );
 893 }
 894
 895 =item $c->stash
 896
 897 Returns a hashref containing all your data.
 898
 899     $c->stash->{foo} ||= 'yada';
 900     print $c->stash->{foo};
 901
 902 =cut
 903
 904 sub stash {
 905     my $self = shift;
 906     if ( $_[0] ) {
 907         my $stash = $_[1] ? {@_} : $_[0];
 908         while ( my ( $key, $val ) = each %$stash ) {
 909             $self->{stash}->{$key} = $val;
 910         }
 911     }
 912     return $self->{stash};
 913 }
 914
 915 sub _prefix {
 916     my ( $class, $name ) = @_;
 917     my $prefix = _class2prefix($class);
 918     $name = "$prefix/$name" if $prefix;
 919     return $name;
 920 }
 921
 922 sub _class2prefix {
 923     my $class = shift || '';
 924     my $prefix;
 925     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
 926         $prefix = lc $2;
 927         $prefix =~ s/\:\:/\//g;
 928     }
 929     return $prefix;
 930 }
 931
 932 =back
 933
 934 =head1 AUTHOR
 935
 936 Sebastian Riedel, C<sri@cpan.org>
 937
 938 =head1 COPYRIGHT
 939
 940 This program is free software, you can redistribute it and/or modify it under
 941 the same terms as Perl itself.
 942
 943 =cut
 944
 945 1;