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