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