lib/Catalyst/Engine.pm

   1 package Catalyst::Engine;
   2
   3 use strict;
   4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
   5 use UNIVERSAL::require;
   6 use CGI::Cookie;
   7 use Data::Dumper;
   8 use HTML::Entities;
   9 use HTTP::Headers;
  10 use Memoize;
  11 use Time::HiRes qw/gettimeofday tv_interval/;
  12 use Text::ASCIITable;
  13 use Text::ASCIITable::Wrap 'wrap';
  14 use Tree::Simple;
  15 use Tree::Simple::Visitor::FindByPath;
  16 use Catalyst::Request;
  17 use Catalyst::Response;
  18
  19 require Module::Pluggable::Fast;
  20
  21 $Data::Dumper::Terse = 1;
  22
  23 __PACKAGE__->mk_classdata($_) for qw/actions components tree/;
  24 __PACKAGE__->mk_accessors(qw/request response state/);
  25
  26 __PACKAGE__->actions(
  27     { plain => {}, private => {}, regex => {}, compiled => [], reverse => {} }
  28 );
  29 __PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
  30
  31 *comp = \&component;
  32 *req  = \&request;
  33 *res  = \&response;
  34
  35 our $COUNT = 1;
  36 our $START = time;
  37
  38 memoize('_class2prefix');
  39
  40 =head1 NAME
  41
  42 Catalyst::Engine - The Catalyst Engine
  43
  44 =head1 SYNOPSIS
  45
  46 See L<Catalyst>.
  47
  48 =head1 DESCRIPTION
  49
  50 =head1 METHODS
  51
  52 =over 4
  53
  54 =item $c->benchmark($coderef)
  55
  56 Takes a coderef with arguments and returns elapsed time as float.
  57
  58     my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
  59     $c->log->info( sprintf "Processing took %f seconds", $elapsed );
  60
  61 =cut
  62
  63 sub benchmark {
  64     my $c       = shift;
  65     my $code    = shift;
  66     my $time    = [gettimeofday];
  67     my @return  = &$code(@_);
  68     my $elapsed = tv_interval $time;
  69     return wantarray ? ( $elapsed, @return ) : $elapsed;
  70 }
  71
  72 =item $c->comp($name)
  73
  74 =item $c->component($name)
  75
  76 Get a component object by name.
  77
  78     $c->comp('MyApp::Model::MyModel')->do_stuff;
  79
  80 Regex search for a component.
  81
  82     $c->comp('mymodel')->do_stuff;
  83
  84 =cut
  85
  86 sub component {
  87     my ( $c, $name ) = @_;
  88     if ( my $component = $c->components->{$name} ) {
  89         return $component;
  90     }
  91     else {
  92         for my $component ( keys %{ $c->components } ) {
  93             return $c->components->{$component} if $component =~ /$name/i;
  94         }
  95     }
  96 }
  97
  98 =item $c->dispatch
  99
 100 Dispatch request to actions.
 101
 102 =cut
 103
 104 sub dispatch {
 105     my $c         = shift;
 106     my $action    = $c->req->action;
 107     my $namespace = '';
 108     $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
 109       if $action eq 'default';
 110     unless ($namespace) {
 111         if ( my $result = $c->get_action($action) ) {
 112             $namespace = _class2prefix( $result->[0]->[0]->[0] );
 113         }
 114     }
 115     my $default = $action eq 'default' ? $namespace : undef;
 116     my $results = $c->get_action( $action, $default );
 117     $namespace ||= '/';
 118     if ( @{$results} ) {
 119
 120         # Execute last begin
 121         $c->state(1);
 122         if ( my $begin = @{ $c->get_action( 'begin', $namespace ) }[-1] ) {
 123             $c->execute( @{ $begin->[0] } );
 124             return if scalar @{ $c->error };
 125         }
 126
 127         # Execute the auto chain
 128         for my $auto ( @{ $c->get_action( 'auto', $namespace ) } ) {
 129             $c->execute( @{ $auto->[0] } );
 130             return if scalar @{ $c->error };
 131             last unless $c->state;
 132         }
 133
 134         # Execute the action or last default
 135         if ( ( my $action = $c->req->action ) && $c->state ) {
 136             if ( my $result = @{ $c->get_action( $action, $default ) }[-1] ) {
 137                 $c->execute( @{ $result->[0] } );
 138             }
 139         }
 140
 141         # Execute last end
 142         if ( my $end = @{ $c->get_action( 'end', $namespace ) }[-1] ) {
 143             $c->execute( @{ $end->[0] } );
 144             return if scalar @{ $c->error };
 145         }
 146     }
 147     else {
 148         my $path  = $c->req->path;
 149         my $error = $path
 150           ? qq/Unknown resource "$path"/
 151           : "No default action defined";
 152         $c->log->error($error) if $c->debug;
 153         $c->error($error);
 154     }
 155 }
 156
 157 =item $c->error
 158
 159 =item $c->error($error, ...)
 160
 161 =item $c->error($arrayref)
 162
 163 Returns an arrayref containing error messages.
 164
 165     my @error = @{ $c->error };
 166
 167 Add a new error.
 168
 169     $c->error('Something bad happened');
 170
 171 =cut
 172
 173 sub error {
 174     my $c = shift;
 175     my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
 176     push @{ $c->{error} }, @$error;
 177     return $c->{error};
 178 }
 179
 180 =item $c->execute($class, $coderef)
 181
 182 Execute a coderef in given class and catch exceptions.
 183 Errors are available via $c->error.
 184
 185 =cut
 186
 187 sub execute {
 188     my ( $c, $class, $code ) = @_;
 189     $class = $c->comp($class) || $class;
 190     $c->state(0);
 191     my $callsub = ( caller(1) )[3];
 192     eval {
 193         if ( $c->debug )
 194         {
 195             my $action = $c->actions->{reverse}->{"$code"};
 196             $action = "/$action" unless $action =~ /\-\>/;
 197             $action = "-> $action" if $callsub =~ /forward$/;
 198             my ( $elapsed, @state ) =
 199               $c->benchmark( $code, $class, $c, @{ $c->req->args } );
 200             push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
 201             $c->state(@state);
 202         }
 203         else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
 204     };
 205     if ( my $error = $@ ) {
 206
 207         unless ( ref $error ) {
 208             chomp $error;
 209             $error = qq/Caught exception "$error"/;
 210         }
 211
 212         $c->log->error($error);
 213         $c->error($error);
 214         $c->state(0);
 215     }
 216     return $c->state;
 217 }
 218
 219 =item $c->finalize
 220
 221 Finalize request.
 222
 223 =cut
 224
 225 sub finalize {
 226     my $c = shift;
 227
 228     $c->finalize_cookies;
 229
 230     if ( my $location = $c->response->redirect ) {
 231         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
 232         $c->response->header( Location => $location );
 233         $c->response->status(302) if $c->response->status !~ /3\d\d$/;
 234     }
 235
 236     if ( $#{ $c->error } >= 0 ) {
 237         $c->finalize_error;
 238     }
 239
 240     if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
 241         $c->finalize_error;
 242     }
 243
 244     if ( $c->response->output && !$c->response->content_length ) {
 245         use bytes;    # play safe with a utf8 aware perl
 246         $c->response->content_length( length $c->response->output );
 247     }
 248
 249     my $status = $c->finalize_headers;
 250     $c->finalize_output;
 251     return $status;
 252 }
 253
 254 =item $c->finalize_cookies
 255
 256 Finalize cookies.
 257
 258 =cut
 259
 260 sub finalize_cookies {
 261     my $c = shift;
 262
 263     while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
 264         my $cookie = CGI::Cookie->new(
 265             -name    => $name,
 266             -value   => $cookie->{value},
 267             -expires => $cookie->{expires},
 268             -domain  => $cookie->{domain},
 269             -path    => $cookie->{path},
 270             -secure  => $cookie->{secure} || 0
 271         );
 272
 273         $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
 274     }
 275 }
 276
 277 =item $c->finalize_error
 278
 279 Finalize error.
 280
 281 =cut
 282
 283 sub finalize_error {
 284     my $c = shift;
 285
 286     $c->res->headers->content_type('text/html');
 287     my $name = $c->config->{name} || 'Catalyst Application';
 288
 289     my ( $title, $error, $infos );
 290     if ( $c->debug ) {
 291         $error = join '<br/>', @{ $c->error };
 292         $error ||= 'No output';
 293         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 294         my $req   = encode_entities Dumper $c->req;
 295         my $res   = encode_entities Dumper $c->res;
 296         my $stash = encode_entities Dumper $c->stash;
 297         $infos = <<"";
 298 <br/>
 299 <b><u>Request</u></b><br/>
 300 <pre>$req</pre>
 301 <b><u>Response</u></b><br/>
 302 <pre>$res</pre>
 303 <b><u>Stash</u></b><br/>
 304 <pre>$stash</pre>
 305
 306     }
 307     else {
 308         $title = $name;
 309         $error = '';
 310         $infos = <<"";
 311 <pre>
 312 (en) Please come back later
 313 (de) Bitte versuchen sie es spaeter nocheinmal
 314 (nl) Gelieve te komen later terug
 315 (no) Vennligst prov igjen senere
 316 (fr) Veuillez revenir plus tard
 317 (es) Vuelto por favor mas adelante
 318 (pt) Voltado por favor mais tarde
 319 (it) Ritornato prego più successivamente
 320 </pre>
 321
 322         $name = '';
 323     }
 324     $c->res->output( <<"" );
 325 <html>
 326 <head>
 327     <title>$title</title>
 328     <style type="text/css">
 329         body {
 330             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 331                          Tahoma, Arial, helvetica, sans-serif;
 332             color: #ddd;
 333             background-color: #eee;
 334             margin: 0px;
 335             padding: 0px;
 336         }
 337         div.box {
 338             background-color: #ccc;
 339             border: 1px solid #aaa;
 340             padding: 4px;
 341             margin: 10px;
 342             -moz-border-radius: 10px;
 343         }
 344         div.error {
 345             background-color: #977;
 346             border: 1px solid #755;
 347             padding: 8px;
 348             margin: 4px;
 349             margin-bottom: 10px;
 350             -moz-border-radius: 10px;
 351         }
 352         div.infos {
 353             background-color: #797;
 354             border: 1px solid #575;
 355             padding: 8px;
 356             margin: 4px;
 357             margin-bottom: 10px;
 358             -moz-border-radius: 10px;
 359         }
 360         div.name {
 361             background-color: #779;
 362             border: 1px solid #557;
 363             padding: 8px;
 364             margin: 4px;
 365             -moz-border-radius: 10px;
 366         }
 367     </style>
 368 </head>
 369 <body>
 370     <div class="box">
 371         <div class="error">$error</div>
 372         <div class="infos">$infos</div>
 373         <div class="name">$name</div>
 374     </div>
 375 </body>
 376 </html>
 377
 378 }
 379
 380 =item $c->finalize_headers
 381
 382 Finalize headers.
 383
 384 =cut
 385
 386 sub finalize_headers { }
 387
 388 =item $c->finalize_output
 389
 390 Finalize output.
 391
 392 =cut
 393
 394 sub finalize_output { }
 395
 396 =item $c->forward($command)
 397
 398 Forward processing to a private action or a method from a class.
 399 If you define a class without method it will default to process().
 400
 401     $c->forward('/foo');
 402     $c->forward('index');
 403     $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
 404     $c->forward('MyApp::View::TT');
 405
 406 =cut
 407
 408 sub forward {
 409     my $c       = shift;
 410     my $command = shift;
 411     unless ($command) {
 412         $c->log->debug('Nothing to forward to') if $c->debug;
 413         return 0;
 414     }
 415     my $caller    = caller(0);
 416     my $namespace = '/';
 417     if ( $command =~ /^\// ) {
 418         $command =~ /^(.*)\/(\w+)$/;
 419         $namespace = $1 || '/';
 420         $command = $2;
 421     }
 422     else { $namespace = _class2prefix($caller) || '/' }
 423     my $results = $c->get_action( $command, $namespace );
 424     unless ( @{$results} ) {
 425         my $class = $command;
 426         if ( $class =~ /[^\w\:]/ ) {
 427             $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
 428             return 0;
 429         }
 430         my $method = shift || 'process';
 431         if ( my $code = $class->can($method) ) {
 432             $c->actions->{reverse}->{"$code"} = "$class->$method";
 433             $results = [ [ [ $class, $code ] ] ];
 434         }
 435         else {
 436             $c->log->debug(qq/Couldn't forward to "$class->$method"/)
 437               if $c->debug;
 438             return 0;
 439         }
 440     }
 441     for my $result ( @{$results} ) {
 442         $c->execute( @{ $result->[0] } );
 443         return if scalar @{ $c->error };
 444         last unless $c->state;
 445     }
 446     return $c->state;
 447 }
 448
 449 =item $c->get_action( $action, $namespace )
 450
 451 Get an action in a given namespace.
 452
 453 =cut
 454
 455 sub get_action {
 456     my ( $c, $action, $namespace ) = @_;
 457     return [] unless $action;
 458     $namespace ||= '';
 459     if ($namespace) {
 460         $namespace = '' if $namespace eq '/';
 461         my $parent = $c->tree;
 462         my @results;
 463         my %allowed = ( begin => 1, auto => 1, default => 1, end => 1 );
 464         if ( $allowed{$action} ) {
 465             my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
 466             push @results, [$result] if $result;
 467             my $visitor = Tree::Simple::Visitor::FindByPath->new;
 468             for my $part ( split '/', $namespace ) {
 469                 $visitor->setSearchPath($part);
 470                 $parent->accept($visitor);
 471                 my $child = $visitor->getResult;
 472                 my $uid   = $child->getUID if $child;
 473                 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
 474                 push @results, [$match] if $match;
 475                 $parent = $child if $child;
 476             }
 477         }
 478         else {
 479             if ($namespace) {
 480                 my $visitor = Tree::Simple::Visitor::FindByPath->new;
 481                 $visitor->setSearchPath( split '/', $namespace );
 482                 $parent->accept($visitor);
 483                 my $child = $visitor->getResult;
 484                 my $uid   = $child->getUID if $child;
 485                 my $match = $c->actions->{private}->{$uid}->{$action}
 486                   if $uid;
 487                 push @results, [$match] if $match;
 488             }
 489             else {
 490                 my $result =
 491                   $c->actions->{private}->{ $parent->getUID }->{$action};
 492                 push @results, [$result] if $result;
 493             }
 494         }
 495         return \@results;
 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 Handles the request.
 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.
 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.
 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.
 695
 696 =cut
 697
 698 sub prepare_headers { }
 699
 700 =item $c->prepare_parameters
 701
 702 Prepare parameters.
 703
 704 =cut
 705
 706 sub prepare_parameters { }
 707
 708 =item $c->prepare_path
 709
 710 Prepare path and base.
 711
 712 =cut
 713
 714 sub prepare_path { }
 715
 716 =item $c->prepare_request
 717
 718 Prepare the engine request.
 719
 720 =cut
 721
 722 sub prepare_request { }
 723
 724 =item $c->prepare_uploads
 725
 726 Prepare uploads.
 727
 728 =cut
 729
 730 sub prepare_uploads { }
 731
 732 =item $c->run
 733
 734 Starts the engine.
 735
 736 =cut
 737
 738 sub run { }
 739
 740 =item $c->request
 741
 742 =item $c->req
 743
 744 Returns a C<Catalyst::Request> object.
 745
 746     my $req = $c->req;
 747
 748 =item $c->response
 749
 750 =item $c->res
 751
 752 Returns a C<Catalyst::Response> object.
 753
 754     my $res = $c->res;
 755
 756 =item $c->set_action( $action, $code, $namespace, $attrs )
 757
 758 Set an action in a given namespace.
 759
 760 =cut
 761
 762 sub set_action {
 763     my ( $c, $method, $code, $namespace, $attrs ) = @_;
 764
 765     my $prefix = _class2prefix($namespace) || '';
 766     my %flags;
 767
 768     for my $attr ( @{$attrs} ) {
 769         if    ( $attr =~ /^(Local|Relative)$/ )        { $flags{local}++ }
 770         elsif ( $attr =~ /^(Global|Absolute)$/ )       { $flags{global}++ }
 771         elsif ( $attr =~ /^Path\((.+)\)$/i )           { $flags{path} = $1 }
 772         elsif ( $attr =~ /^Private$/i )                { $flags{private}++ }
 773         elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
 774     }
 775
 776     return unless keys %flags;
 777
 778     my $parent  = $c->tree;
 779     my $visitor = Tree::Simple::Visitor::FindByPath->new;
 780     for my $part ( split '/', $prefix ) {
 781         $visitor->setSearchPath($part);
 782         $parent->accept($visitor);
 783         my $child = $visitor->getResult;
 784         unless ($child) {
 785             $child = $parent->addChild( Tree::Simple->new($part) );
 786             $visitor->setSearchPath($part);
 787             $parent->accept($visitor);
 788             $child = $visitor->getResult;
 789         }
 790         $parent = $child;
 791     }
 792     my $uid = $parent->getUID;
 793     $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
 794     my $forward = $prefix ? "$prefix/$method" : $method;
 795
 796     if ( $flags{path} ) {
 797         $flags{path} =~ s/^\w+//;
 798         $flags{path} =~ s/\w+$//;
 799         if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
 800         if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
 801     }
 802     if ( $flags{regex} ) {
 803         $flags{regex} =~ s/^\w+//;
 804         $flags{regex} =~ s/\w+$//;
 805         if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
 806         if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
 807     }
 808
 809     my $reverse = $prefix ? "$prefix/$method" : $method;
 810
 811     if ( $flags{local} || $flags{global} || $flags{path} ) {
 812         my $path = $flags{path} || $method;
 813         my $absolute = 0;
 814         if ( $path =~ /^\/(.+)/ ) {
 815             $path     = $1;
 816             $absolute = 1;
 817         }
 818         $absolute = 1 if $flags{global};
 819         my $name = $absolute ? $path : $prefix ? "$prefix/$path" : $path;
 820         $c->actions->{plain}->{$name} = [ $namespace, $code ];
 821     }
 822     if ( my $regex = $flags{regex} ) {
 823         push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
 824         $c->actions->{regex}->{$regex} = [ $namespace, $code ];
 825     }
 826
 827     $c->actions->{reverse}->{"$code"} = $reverse;
 828 }
 829
 830 =item $class->setup
 831
 832 Setup.
 833
 834     MyApp->setup;
 835
 836 =cut
 837
 838 sub setup {
 839     my $self = shift;
 840     $self->setup_components;
 841     if ( $self->debug ) {
 842         my $name = $self->config->{name} || 'Application';
 843         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 844     }
 845 }
 846
 847 =item $class->setup_actions($component)
 848
 849 Setup actions for a component.
 850
 851 =cut
 852
 853 sub setup_actions {
 854     my ( $self, $comp ) = @_;
 855     $comp = ref $comp || $comp;
 856     for my $action ( @{ $comp->_cache } ) {
 857         my ( $code, $attrs ) = @{$action};
 858         my $name = '';
 859         no strict 'refs';
 860         my @cache = ( $comp, @{"$comp\::ISA"} );
 861         my %namespaces;
 862         while ( my $namespace = shift @cache ) {
 863             $namespaces{$namespace}++;
 864             for my $isa ( @{"$comp\::ISA"} ) {
 865                 next if $namespaces{$isa};
 866                 push @cache, $isa;
 867                 $namespaces{$isa}++;
 868             }
 869         }
 870         for my $namespace ( keys %namespaces ) {
 871             for my $sym ( values %{ $namespace . '::' } ) {
 872                 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
 873                     $name = *{$sym}{NAME};
 874                     $self->set_action( $name, $code, $comp, $attrs );
 875                     last;
 876                 }
 877             }
 878         }
 879     }
 880 }
 881
 882 =item $class->setup_components
 883
 884 Setup components.
 885
 886 =cut
 887
 888 sub setup_components {
 889     my $self = shift;
 890
 891     # Components
 892     my $class = ref $self || $self;
 893     eval <<"";
 894         package $class;
 895         import Module::Pluggable::Fast
 896           name   => '_components',
 897           search => [
 898             '$class\::Controller', '$class\::C',
 899             '$class\::Model',      '$class\::M',
 900             '$class\::View',       '$class\::V'
 901           ];
 902
 903     if ( my $error = $@ ) {
 904         chomp $error;
 905         $self->log->error(
 906             qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
 907     }
 908     $self->setup_actions($self);
 909     $self->components( {} );
 910     for my $comp ( $self->_components($self) ) {
 911         $self->components->{ ref $comp } = $comp;
 912         $self->setup_actions($comp);
 913     }
 914     my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
 915     $t->setCols('Class');
 916     $t->setColWidth( 'Class', 75, 1 );
 917     $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
 918     $self->log->debug( 'Loaded components', $t->draw )
 919       if ( @{ $t->{tbl_rows} } && $self->debug );
 920     my $actions  = $self->actions;
 921     my $privates = Text::ASCIITable->new;
 922     $privates->setCols( 'Private', 'Class', 'Code' );
 923     $privates->setColWidth( 'Private', 28, 1 );
 924     $privates->setColWidth( 'Class',   28, 1 );
 925     $privates->setColWidth( 'Code',    14, 1 );
 926     my $walker = sub {
 927         my ( $walker, $parent, $prefix ) = @_;
 928         $prefix .= $parent->getNodeValue || '';
 929         $prefix .= '/' unless $prefix =~ /\/$/;
 930         my $uid = $parent->getUID;
 931         for my $action ( keys %{ $actions->{private}->{$uid} } ) {
 932             my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
 933             $privates->addRow(
 934                 wrap( "$prefix$action", 28 ),
 935                 wrap( $class,           28 ),
 936                 wrap( $code,            14 )
 937             );
 938         }
 939         $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
 940     };
 941     $walker->( $walker, $self->tree, '' );
 942     $self->log->debug( 'Loaded private actions', $privates->draw )
 943       if ( @{ $privates->{tbl_rows} } && $self->debug );
 944     my $publics = Text::ASCIITable->new;
 945     $publics->setCols( 'Public', 'Private' );
 946     $publics->setColWidth( 'Public',  37, 1 );
 947     $publics->setColWidth( 'Private', 36, 1 );
 948
 949     for my $plain ( sort keys %{ $actions->{plain} } ) {
 950         my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
 951         $publics->addRow( wrap( "/$plain", 37 ),
 952             wrap( $self->actions->{reverse}->{$code} || $code, 36 ) );
 953     }
 954     $self->log->debug( 'Loaded public actions', $publics->draw )
 955       if ( @{ $publics->{tbl_rows} } && $self->debug );
 956     my $regexes = Text::ASCIITable->new;
 957     $regexes->setCols( 'Regex', 'Private' );
 958     $regexes->setColWidth( 'Regex',   37, 1 );
 959     $regexes->setColWidth( 'Private', 36, 1 );
 960     for my $regex ( sort keys %{ $actions->{regex} } ) {
 961         my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
 962         $regexes->addRow( wrap( $regex, 37 ),
 963             wrap( $self->actions->{reverse}->{$class} || $class, 36 ) );
 964     }
 965     $self->log->debug( 'Loaded regex actions', $regexes->draw )
 966       if ( @{ $regexes->{tbl_rows} } && $self->debug );
 967 }
 968
 969 =item $c->state
 970
 971 Contains the return value of the last executed action.
 972
 973 =item $c->stash
 974
 975 Returns a hashref containing all your data.
 976
 977     $c->stash->{foo} ||= 'yada';
 978     print $c->stash->{foo};
 979
 980 =cut
 981
 982 sub stash {
 983     my $self = shift;
 984     if ( $_[0] ) {
 985         my $stash = $_[1] ? {@_} : $_[0];
 986         while ( my ( $key, $val ) = each %$stash ) {
 987             $self->{stash}->{$key} = $val;
 988         }
 989     }
 990     return $self->{stash};
 991 }
 992
 993 sub _prefix {
 994     my ( $class, $name ) = @_;
 995     my $prefix = _class2prefix($class);
 996     $name = "$prefix/$name" if $prefix;
 997     return $name;
 998 }
 999
1000 sub _class2prefix {
1001     my $class = shift || '';
1002     my $prefix;
1003     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
1004         $prefix = lc $2;
1005         $prefix =~ s/\:\:/\//g;
1006     }
1007     return $prefix;
1008 }
1009
1010 =back
1011
1012 =head1 AUTHOR
1013
1014 Sebastian Riedel, C<sri@cpan.org>
1015
1016 =head1 COPYRIGHT
1017
1018 This program is free software, you can redistribute it and/or modify it under
1019 the same terms as Perl itself.
1020
1021 =cut
1022
1023 1;