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