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