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