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