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