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