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