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