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 $global    = $command =~ /^\// ? 0 : 1;
 417     my $namespace = '/';
 418     if ( $command =~ /^\// ) {
 419         $command =~ /^(.*)\/(\w+)$/;
 420         $namespace = $1 || '/';
 421         $command = $2;
 422     }
 423     else { $namespace = _class2prefix($caller) || '/' }
 424     my $results = $c->get_action( $command, $namespace, $global );
 425     unless ( @{$results} ) {
 426         my $class = $command;
 427         if ( $class =~ /[^\w\:]/ ) {
 428             $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
 429             return 0;
 430         }
 431         my $method = shift || 'process';
 432         if ( my $code = $class->can($method) ) {
 433             $c->actions->{reverse}->{"$code"} = "$class->$method";
 434             $results = [ [ [ $class, $code ] ] ];
 435         }
 436         else {
 437             $c->log->debug(qq/Couldn't forward to "$class->$method"/)
 438               if $c->debug;
 439             return 0;
 440         }
 441     }
 442     for my $result ( @{$results} ) {
 443         $c->execute( @{ $result->[0] } );
 444         return if scalar @{ $c->error };
 445         last unless $c->state;
 446     }
 447     return $c->state;
 448 }
 449
 450 =item $c->get_action( $action, $namespace, $global )
 451
 452 Get an action in a given namespace.
 453
 454 =cut
 455
 456 sub get_action {
 457     my ( $c, $action, $namespace, $global ) = @_;
 458     return [] unless $action;
 459     $namespace ||= '';
 460     if ($namespace) {
 461         if ($global) {
 462             my @results;
 463             for my $uid ( keys %{ $c->actions->{private} } ) {
 464                 if ( my $result = $c->actions->{private}->{$uid}->{$action} ) {
 465                     push @results, [$result];
 466                 }
 467             }
 468             return \@results;
 469         }
 470         else {
 471             $namespace = '' if $namespace eq '/';
 472             my $parent = $c->tree;
 473             my @results;
 474             my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
 475             push @results, [$result] if $result;
 476             my $visitor = Tree::Simple::Visitor::FindByPath->new;
 477             for my $part ( split '/', $namespace ) {
 478                 $visitor->setSearchPath($part);
 479                 $parent->accept($visitor);
 480                 my $child = $visitor->getResult;
 481                 my $uid   = $child->getUID if $child;
 482                 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
 483                 push @results, [$match] if $match;
 484                 $parent = $child if $child;
 485             }
 486             return \@results;
 487         }
 488     }
 489     elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
 490     elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
 491     else {
 492         for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
 493             my $name  = $c->actions->{compiled}->[$i]->[0];
 494             my $regex = $c->actions->{compiled}->[$i]->[1];
 495             if ( $action =~ $regex ) {
 496                 my @snippets;
 497                 for my $i ( 1 .. 9 ) {
 498                     no strict 'refs';
 499                     last unless ${$i};
 500                     push @snippets, ${$i};
 501                 }
 502                 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
 503             }
 504         }
 505     }
 506     return [];
 507 }
 508
 509 =item $c->handler( $class, $r )
 510
 511 Handles the request.
 512
 513 =cut
 514
 515 sub handler {
 516     my ( $class, $engine ) = @_;
 517
 518     # Always expect worst case!
 519     my $status = -1;
 520     eval {
 521         my @stats = ();
 522         my $handler = sub {
 523             my $c = $class->prepare($engine);
 524             $c->{stats} = \@stats;
 525             $c->dispatch;
 526             return $c->finalize;
 527         };
 528         if ( $class->debug ) {
 529             my $elapsed;
 530             ( $elapsed, $status ) = $class->benchmark($handler);
 531             $elapsed = sprintf '%f', $elapsed;
 532             my $av = sprintf '%.3f', 1 / $elapsed;
 533             my $t = Text::ASCIITable->new;
 534             $t->setCols( 'Action', 'Time' );
 535             $t->setColWidth( 'Action', 64, 1 );
 536             $t->setColWidth( 'Time',   9,  1 );
 537
 538             for my $stat (@stats) {
 539                 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
 540             }
 541             $class->log->info( "Request took $elapsed" . "s ($av/s)",
 542                 $t->draw );
 543         }
 544         else { $status = &$handler }
 545     };
 546     if ( my $error = $@ ) {
 547         chomp $error;
 548         $class->log->error(qq/Caught exception in engine "$error"/);
 549     }
 550     $COUNT++;
 551     return $status;
 552 }
 553
 554 =item $c->prepare($r)
 555
 556 Turns the engine-specific request( Apache, CGI ... )
 557 into a Catalyst context .
 558
 559 =cut
 560
 561 sub prepare {
 562     my ( $class, $r ) = @_;
 563     my $c = bless {
 564         request => Catalyst::Request->new(
 565             {
 566                 arguments  => [],
 567                 cookies    => {},
 568                 headers    => HTTP::Headers->new,
 569                 parameters => {},
 570                 snippets   => [],
 571                 uploads    => {}
 572             }
 573         ),
 574         response => Catalyst::Response->new(
 575             { cookies => {}, headers => HTTP::Headers->new, status => 200 }
 576         ),
 577         stash => {},
 578         state => 0
 579     }, $class;
 580     if ( $c->debug ) {
 581         my $secs = time - $START || 1;
 582         my $av = sprintf '%.3f', $COUNT / $secs;
 583         $c->log->debug('**********************************');
 584         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 585         $c->log->debug('**********************************');
 586         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 587     }
 588     $c->prepare_request($r);
 589     $c->prepare_path;
 590     $c->prepare_headers;
 591     $c->prepare_cookies;
 592     $c->prepare_connection;
 593     my $method   = $c->req->method   || '';
 594     my $path     = $c->req->path     || '';
 595     my $hostname = $c->req->hostname || '';
 596     my $address  = $c->req->address  || '';
 597     $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
 598       if $c->debug;
 599     $c->prepare_action;
 600     $c->prepare_parameters;
 601
 602     if ( $c->debug && keys %{ $c->req->params } ) {
 603         my $t = Text::ASCIITable->new;
 604         $t->setCols( 'Key', 'Value' );
 605         $t->setColWidth( 'Key',   37, 1 );
 606         $t->setColWidth( 'Value', 36, 1 );
 607         for my $key ( keys %{ $c->req->params } ) {
 608             my $value = $c->req->params->{$key} || '';
 609             $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
 610         }
 611         $c->log->debug( 'Parameters are', $t->draw );
 612     }
 613     $c->prepare_uploads;
 614     return $c;
 615 }
 616
 617 =item $c->prepare_action
 618
 619 Prepare action.
 620
 621 =cut
 622
 623 sub prepare_action {
 624     my $c    = shift;
 625     my $path = $c->req->path;
 626     my @path = split /\//, $c->req->path;
 627     $c->req->args( \my @args );
 628     while (@path) {
 629         $path = join '/', @path;
 630         if ( my $result = ${ $c->get_action($path) }[0] ) {
 631
 632             # It's a regex
 633             if ($#$result) {
 634                 my $match    = $result->[1];
 635                 my @snippets = @{ $result->[2] };
 636                 $c->log->debug(
 637                     qq/Requested action is "$path" and matched "$match"/)
 638                   if $c->debug;
 639                 $c->log->debug(
 640                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 641                   if ( $c->debug && @snippets );
 642                 $c->req->action($match);
 643                 $c->req->snippets( \@snippets );
 644             }
 645             else {
 646                 $c->req->action($path);
 647                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 648             }
 649             $c->req->match($path);
 650             last;
 651         }
 652         unshift @args, pop @path;
 653     }
 654     unless ( $c->req->action ) {
 655         $c->req->action('default');
 656         $c->req->match('');
 657     }
 658     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 659       if ( $c->debug && @args );
 660 }
 661
 662 =item $c->prepare_connection
 663
 664 Prepare connection.
 665
 666 =cut
 667
 668 sub prepare_connection { }
 669
 670 =item $c->prepare_cookies
 671
 672 Prepare cookies.
 673
 674 =cut
 675
 676 sub prepare_cookies {
 677     my $c = shift;
 678
 679     if ( my $header = $c->request->header('Cookie') ) {
 680         $c->req->cookies( { CGI::Cookie->parse($header) } );
 681     }
 682 }
 683
 684 =item $c->prepare_headers
 685
 686 Prepare headers.
 687
 688 =cut
 689
 690 sub prepare_headers { }
 691
 692 =item $c->prepare_parameters
 693
 694 Prepare parameters.
 695
 696 =cut
 697
 698 sub prepare_parameters { }
 699
 700 =item $c->prepare_path
 701
 702 Prepare path and base.
 703
 704 =cut
 705
 706 sub prepare_path { }
 707
 708 =item $c->prepare_request
 709
 710 Prepare the engine request.
 711
 712 =cut
 713
 714 sub prepare_request { }
 715
 716 =item $c->prepare_uploads
 717
 718 Prepare uploads.
 719
 720 =cut
 721
 722 sub prepare_uploads { }
 723
 724 =item $c->run
 725
 726 Starts the engine.
 727
 728 =cut
 729
 730 sub run { }
 731
 732 =item $c->request
 733
 734 =item $c->req
 735
 736 Returns a C<Catalyst::Request> object.
 737
 738     my $req = $c->req;
 739
 740 =item $c->response
 741
 742 =item $c->res
 743
 744 Returns a C<Catalyst::Response> object.
 745
 746     my $res = $c->res;
 747
 748 =item $c->set_action( $action, $code, $namespace, $attrs )
 749
 750 Set an action in a given namespace.
 751
 752 =cut
 753
 754 sub set_action {
 755     my ( $c, $method, $code, $namespace, $attrs ) = @_;
 756
 757     my $prefix = _class2prefix($namespace) || '';
 758     my %flags;
 759
 760     for my $attr ( @{$attrs} ) {
 761         if    ( $attr =~ /^(Local|Relative)$/ )        { $flags{local}++ }
 762         elsif ( $attr =~ /^(Global|Absolute)$/ )       { $flags{global}++ }
 763         elsif ( $attr =~ /^Path\((.+)\)$/i )           { $flags{path} = $1 }
 764         elsif ( $attr =~ /^Private$/i )                { $flags{private}++ }
 765         elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
 766     }
 767
 768     return unless keys %flags;
 769
 770     my $parent  = $c->tree;
 771     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 772     for my $part ( split '/', $prefix ) {
 773         $visitor->setSearchPath($part);
 774         $parent->accept($visitor);
 775         my $child = $visitor->getResult;
 776         unless ($child) {
 777             $child = $parent->addChild( Tree::Simple->new($part) );
 778             $visitor->setSearchPath($part);
 779             $parent->accept($visitor);
 780             $child = $visitor->getResult;
 781         }
 782         $parent = $child;
 783     }
 784     my $uid = $parent->getUID;
 785     $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
 786     my $forward = $prefix ? "$prefix/$method" : $method;
 787
 788     if ( $flags{path} ) {
 789         $flags{path} =~ s/^\w+//;
 790         $flags{path} =~ s/\w+$//;
 791         if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
 792         if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
 793     }
 794     if ( $flags{regex} ) {
 795         $flags{regex} =~ s/^\w+//;
 796         $flags{regex} =~ s/\w+$//;
 797         if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
 798         if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
 799     }
 800
 801     my $reverse = $prefix ? "$prefix/$method" : $method;
 802
 803     if ( $flags{local} || $flags{global} || $flags{path} ) {
 804         my $path = $flags{path} || $method;
 805         my $absolute = 0;
 806         if ( $path =~ /^\/(.+)/ ) {
 807             $path     = $1;
 808             $absolute = 1;
 809         }
 810         $absolute = 1 if $flags{global};
 811         my $name = $absolute ? $path : $prefix ? "$prefix/$path" : $path;
 812         $c->actions->{plain}->{$name} = [ $namespace, $code ];
 813     }
 814     if ( my $regex = $flags{regex} ) {
 815         push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
 816         $c->actions->{regex}->{$regex} = [ $namespace, $code ];
 817     }
 818
 819     $c->actions->{reverse}->{"$code"} = $reverse;
 820 }
 821
 822 =item $class->setup
 823
 824 Setup.
 825
 826     MyApp->setup;
 827
 828 =cut
 829
 830 sub setup {
 831     my $self = shift;
 832     $self->setup_components;
 833     if ( $self->debug ) {
 834         my $name = $self->config->{name} || 'Application';
 835         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 836     }
 837 }
 838
 839 =item $class->setup_actions($component)
 840
 841 Setup actions for a component.
 842
 843 =cut
 844
 845 sub setup_actions {
 846     my ( $self, $comp ) = @_;
 847     $comp = ref $comp || $comp;
 848     for my $action ( @{ $comp->_cache } ) {
 849         my ( $code, $attrs ) = @{$action};
 850         my $name = '';
 851         no strict 'refs';
 852         my @cache = ( $comp, @{"$comp\::ISA"} );
 853         my %namespaces;
 854         while ( my $namespace = shift @cache ) {
 855             $namespaces{$namespace}++;
 856             for my $isa ( @{"$comp\::ISA"} ) {
 857                 next if $namespaces{$isa};
 858                 push @cache, $isa;
 859                 $namespaces{$isa}++;
 860             }
 861         }
 862         for my $namespace ( keys %namespaces ) {
 863             for my $sym ( values %{ $namespace . '::' } ) {
 864                 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
 865                     $name = *{$sym}{NAME};
 866                     $self->set_action( $name, $code, $comp, $attrs );
 867                     last;
 868                 }
 869             }
 870         }
 871     }
 872 }
 873
 874 =item $class->setup_components
 875
 876 Setup components.
 877
 878 =cut
 879
 880 sub setup_components {
 881     my $self = shift;
 882
 883     # Components
 884     my $class = ref $self || $self;
 885     eval <<"";
 886         package $class;
 887         import Module::Pluggable::Fast
 888           name   => '_components',
 889           search => [
 890             '$class\::Controller', '$class\::C',
 891             '$class\::Model',      '$class\::M',
 892             '$class\::View',       '$class\::V'
 893           ];
 894
 895     if ( my $error = $@ ) {
 896         chomp $error;
 897         $self->log->error(
 898             qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
 899     }
 900     $self->setup_actions($self);
 901     $self->components( {} );
 902     for my $comp ( $self->_components($self) ) {
 903         $self->components->{ ref $comp } = $comp;
 904         $self->setup_actions($comp);
 905     }
 906     my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
 907     $t->setCols('Class');
 908     $t->setColWidth( 'Class', 75, 1 );
 909     $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
 910     $self->log->debug( 'Loaded components', $t->draw )
 911       if ( @{ $t->{tbl_rows} } && $self->debug );
 912     my $actions  = $self->actions;
 913     my $privates = Text::ASCIITable->new;
 914     $privates->setCols( 'Private', 'Class', 'Code' );
 915     $privates->setColWidth( 'Private', 28, 1 );
 916     $privates->setColWidth( 'Class',   28, 1 );
 917     $privates->setColWidth( 'Code',    14, 1 );
 918     my $walker = sub {
 919         my ( $walker, $parent, $prefix ) = @_;
 920         $prefix .= $parent->getNodeValue || '';
 921         $prefix .= '/' unless $prefix =~ /\/$/;
 922         my $uid = $parent->getUID;
 923         for my $action ( keys %{ $actions->{private}->{$uid} } ) {
 924             my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
 925             $privates->addRow(
 926                 wrap( "$prefix$action", 28 ),
 927                 wrap( $class,           28 ),
 928                 wrap( $code,            14 )
 929             );
 930         }
 931         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 932     };
 933     $walker->( $walker, $self->tree, '' );
 934     $self->log->debug( 'Loaded private actions', $privates->draw )
 935       if ( @{ $privates->{tbl_rows} } && $self->debug );
 936     my $publics = Text::ASCIITable->new;
 937     $publics->setCols( 'Public', 'Private' );
 938     $publics->setColWidth( 'Public',  37, 1 );
 939     $publics->setColWidth( 'Private', 36, 1 );
 940
 941     for my $plain ( sort keys %{ $actions->{plain} } ) {
 942         my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
 943         $publics->addRow( wrap( "/$plain", 37 ),
 944             wrap( $self->actions->{reverse}->{$code} || $code, 36 ) );
 945     }
 946     $self->log->debug( 'Loaded public actions', $publics->draw )
 947       if ( @{ $publics->{tbl_rows} } && $self->debug );
 948     my $regexes = Text::ASCIITable->new;
 949     $regexes->setCols( 'Regex', 'Private' );
 950     $regexes->setColWidth( 'Regex',   37, 1 );
 951     $regexes->setColWidth( 'Private', 36, 1 );
 952     for my $regex ( sort keys %{ $actions->{regex} } ) {
 953         my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
 954         $regexes->addRow( wrap( $regex, 37 ),
 955             wrap( $self->actions->{reverse}->{$class} || $class, 36 ) );
 956     }
 957     $self->log->debug( 'Loaded regex actions', $regexes->draw )
 958       if ( @{ $regexes->{tbl_rows} } && $self->debug );
 959 }
 960
 961 =item $c->state
 962
 963 Contains the return value of the last executed action.
 964
 965 =item $c->stash
 966
 967 Returns a hashref containing all your data.
 968
 969     $c->stash->{foo} ||= 'yada';
 970     print $c->stash->{foo};
 971
 972 =cut
 973
 974 sub stash {
 975     my $self = shift;
 976     if ( $_[0] ) {
 977         my $stash = $_[1] ? {@_} : $_[0];
 978         while ( my ( $key, $val ) = each %$stash ) {
 979             $self->{stash}->{$key} = $val;
 980         }
 981     }
 982     return $self->{stash};
 983 }
 984
 985 sub _prefix {
 986     my ( $class, $name ) = @_;
 987     my $prefix = _class2prefix($class);
 988     $name = "$prefix/$name" if $prefix;
 989     return $name;
 990 }
 991
 992 sub _class2prefix {
 993     my $class = shift || '';
 994     my $prefix;
 995     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
 996         $prefix = lc $2;
 997         $prefix =~ s/\:\:/\//g;
 998     }
 999     return $prefix;
1000 }
1001
1002 =back
1003
1004 =head1 AUTHOR
1005
1006 Sebastian Riedel, C<sri@cpan.org>
1007
1008 =head1 COPYRIGHT
1009
1010 This program is free software, you can redistribute it and/or modify it under
1011 the same terms as Perl itself.
1012
1013 =cut
1014
1015 1;