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