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