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