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
 209         unless ( ref $error ) {
 210             chomp $error;
 211             $error = qq/Caught exception "$error"/;
 212         }
 213
 214         $c->log->error($error);
 215         $c->error($error);
 216         $c->state(0);
 217     }
 218     return $c->state;
 219 }
 220
 221 =item $c->finalize
 222
 223 Finalize request.
 224
 225 =cut
 226
 227 sub finalize {
 228     my $c = shift;
 229
 230     $c->finalize_cookies;
 231
 232     if ( my $location = $c->response->redirect ) {
 233         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
 234         $c->response->header( Location => $location );
 235         $c->response->status(302) if $c->response->status !~ /3\d\d$/;
 236     }
 237
 238     if ( $#{ $c->error } >= 0 ) {
 239         $c->finalize_error;
 240     }
 241
 242     if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
 243         $c->finalize_error;
 244     }
 245
 246     if ( $c->response->output && !$c->response->content_length ) {
 247         use bytes;    # play safe with a utf8 aware perl
 248         $c->response->content_length( length $c->response->output );
 249     }
 250
 251     my $status = $c->finalize_headers;
 252     $c->finalize_output;
 253     return $status;
 254 }
 255
 256 =item $c->finalize_cookies
 257
 258 Finalize cookies.
 259
 260 =cut
 261
 262 sub finalize_cookies {
 263     my $c = shift;
 264
 265     while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
 266         my $cookie = CGI::Cookie->new(
 267             -name    => $name,
 268             -value   => $cookie->{value},
 269             -expires => $cookie->{expires},
 270             -domain  => $cookie->{domain},
 271             -path    => $cookie->{path},
 272             -secure  => $cookie->{secure} || 0
 273         );
 274
 275         $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
 276     }
 277 }
 278
 279 =item $c->finalize_error
 280
 281 Finalize error.
 282
 283 =cut
 284
 285 sub finalize_error {
 286     my $c = shift;
 287
 288     $c->res->headers->content_type('text/html');
 289     my $name = $c->config->{name} || 'Catalyst Application';
 290
 291     my ( $title, $error, $infos );
 292     if ( $c->debug ) {
 293         $error = join '<br/>', @{ $c->error };
 294         $error ||= 'No output';
 295         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 296         my $req   = encode_entities Dumper $c->req;
 297         my $res   = encode_entities Dumper $c->res;
 298         my $stash = encode_entities Dumper $c->stash;
 299         $infos = <<"";
 300 <br/>
 301 <b><u>Request</u></b><br/>
 302 <pre>$req</pre>
 303 <b><u>Response</u></b><br/>
 304 <pre>$res</pre>
 305 <b><u>Stash</u></b><br/>
 306 <pre>$stash</pre>
 307
 308     }
 309     else {
 310         $title = $name;
 311         $error = '';
 312         $infos = <<"";
 313 <pre>
 314 (en) Please come back later
 315 (de) Bitte versuchen sie es spaeter nocheinmal
 316 (nl) Gelieve te komen later terug
 317 (no) Vennligst prov igjen senere
 318 (fr) Veuillez revenir plus tard
 319 (es) Vuelto por favor mas adelante
 320 (pt) Voltado por favor mais tarde
 321 (it) Ritornato prego più successivamente
 322 </pre>
 323
 324         $name = '';
 325     }
 326     $c->res->output( <<"" );
 327 <html>
 328 <head>
 329     <title>$title</title>
 330     <style type="text/css">
 331         body {
 332             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 333                          Tahoma, Arial, helvetica, sans-serif;
 334             color: #ddd;
 335             background-color: #eee;
 336             margin: 0px;
 337             padding: 0px;
 338         }
 339         div.box {
 340             background-color: #ccc;
 341             border: 1px solid #aaa;
 342             padding: 4px;
 343             margin: 10px;
 344             -moz-border-radius: 10px;
 345         }
 346         div.error {
 347             background-color: #977;
 348             border: 1px solid #755;
 349             padding: 8px;
 350             margin: 4px;
 351             margin-bottom: 10px;
 352             -moz-border-radius: 10px;
 353         }
 354         div.infos {
 355             background-color: #797;
 356             border: 1px solid #575;
 357             padding: 8px;
 358             margin: 4px;
 359             margin-bottom: 10px;
 360             -moz-border-radius: 10px;
 361         }
 362         div.name {
 363             background-color: #779;
 364             border: 1px solid #557;
 365             padding: 8px;
 366             margin: 4px;
 367             -moz-border-radius: 10px;
 368         }
 369     </style>
 370 </head>
 371 <body>
 372     <div class="box">
 373         <div class="error">$error</div>
 374         <div class="infos">$infos</div>
 375         <div class="name">$name</div>
 376     </div>
 377 </body>
 378 </html>
 379
 380 }
 381
 382 =item $c->finalize_headers
 383
 384 Finalize headers.
 385
 386 =cut
 387
 388 sub finalize_headers { }
 389
 390 =item $c->finalize_output
 391
 392 Finalize output.
 393
 394 =cut
 395
 396 sub finalize_output { }
 397
 398 =item $c->forward($command)
 399
 400 Forward processing to a private action or a method from a class.
 401 If you define a class without method it will default to process().
 402
 403     $c->forward('/foo');
 404     $c->forward('index');
 405     $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
 406     $c->forward('MyApp::View::TT');
 407
 408 =cut
 409
 410 sub forward {
 411     my $c       = shift;
 412     my $command = shift;
 413     unless ($command) {
 414         $c->log->debug('Nothing to forward to') if $c->debug;
 415         return 0;
 416     }
 417     my $caller    = caller(0);
 418     my $namespace = '/';
 419     if ( $command =~ /^\// ) {
 420         $command =~ /^(.*)\/(\w+)$/;
 421         $namespace = $1 || '/';
 422         $command = $2;
 423     }
 424     else { $namespace = _class2prefix($caller) || '/' }
 425     my $results = $c->get_action( $command, $namespace );
 426     unless ( @{$results} ) {
 427         my $class = $command;
 428         if ( $class =~ /[^\w\:]/ ) {
 429             $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
 430             return 0;
 431         }
 432         my $method = shift || 'process';
 433         if ( my $code = $class->can($method) ) {
 434             $c->actions->{reverse}->{"$code"} = "$class->$method";
 435             $results = [ [ [ $class, $code ] ] ];
 436         }
 437         else {
 438             $c->log->debug(qq/Couldn't forward to "$class->$method"/)
 439               if $c->debug;
 440             return 0;
 441         }
 442     }
 443     for my $result ( @{$results} ) {
 444         $c->execute( @{ $result->[0] } );
 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/$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;