projects / catagits/Catalyst-Runtime.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
typo
[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 );
4716267f 130 $c->res->headers->remove_content_headers;
23f9d934 131 $c->res->status(302);
4716267f 132 return $c->finalize_headers;
23f9d934 133 }
134
a554cc3b 135 if ( !$c->res->output || $#{ $c->error } >= 0 ) {
fc7ec1d9 136 $c->res->headers->content_type('text/html');
137 my $name = $c->config->{name} || 'Catalyst Application';
a554cc3b 138 my ( $title, $error, $infos );
fc7ec1d9 139 if ( $c->debug ) {
a554cc3b 140 $error = join '<br/>', @{ $c->error };
141 $error ||= 'No output';
fc7ec1d9 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 {
a554cc3b 157 $title = $name;
158 $error = '';
159 $infos = <<"";
fc7ec1d9 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 }
a554cc3b 193 div.error {
fc7ec1d9 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">
a554cc3b 220 <div class="error">$error</div>
fc7ec1d9 221 <div class="infos">$infos</div>
222 <div class="name">$name</div>
223 </div>
224 </body>
225</html>
226
227 }
fc7ec1d9 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
23f9d934 234=item $c->finalize_headers
fc7ec1d9 235
236Finalize headers.
237
238=cut
239
240sub finalize_headers { }
241
23f9d934 242=item $c->finalize_output
fc7ec1d9 243
244Finalize output.
245
246=cut
247
248sub finalize_output { }
249
23f9d934 250=item $c->forward($command)
fc7ec1d9 251
ac733264 252Forward processing to a private action or a method from a class.
fc7ec1d9 253If you define a class without method it will default to process().
254
6196207f 255 $c->forward('/foo');
ac733264 256 $c->forward('index');
fc7ec1d9 257 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
258 $c->forward('MyApp::View::TT');
259
260=cut
261
262sub 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 }
ac733264 269 my $caller = caller(0);
270 my $namespace = '/';
6196207f 271 if ( $command =~ /^\// ) {
89c5fe2d 272 $command =~ /^(.*)\/(\w+)$/;
273 $namespace = $1 || '/';
274 $command = $2;
275 }
ac733264 276 else { $namespace = _class2prefix($caller) || '/' }
66d9e175 277 my $results = $c->get_action( $command, $namespace );
ac733264 278 unless ( @{$results} ) {
b768faa3 279 my $class = $command;
fc7ec1d9 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';
b768faa3 285 if ( my $code = $class->can($method) ) {
fc7ec1d9 286 $c->actions->{reverse}->{"$code"} = "$class->$method";
2deb0d7c 287 $results = [ [ [ $class, $code ] ] ];
fc7ec1d9 288 }
289 else {
290 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
291 if $c->debug;
292 return 0;
293 }
294 }
2deb0d7c 295 for my $result ( @{$results} ) {
970cc51d 296 $c->state( $c->execute( @{ $result->[0] } ) );
2deb0d7c 297 }
b768faa3 298 return $c->state;
fc7ec1d9 299}
300
66d9e175 301=item $c->get_action( $action, $namespace )
302
303Get an action in a given namespace.
304
305=cut
306
307sub get_action {
308 my ( $c, $action, $namespace ) = @_;
309 $namespace ||= '';
ac733264 310 if ($namespace) {
311 $namespace = '' if $namespace eq '/';
66d9e175 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;
6d9a6748 323 push @results, [$match] if $match;
66d9e175 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 {
ac733264 331 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
332 my $name = $c->actions->{compiled}->[$i]->[0];
333 my $regex = $c->actions->{compiled}->[$i]->[1];
66d9e175 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
b76d7db8 348=item $c->handler( $class, $r )
fc7ec1d9 349
350Handles the request.
351
352=cut
353
b76d7db8 354sub handler ($$) {
fc7ec1d9 355 my ( $class, $r ) = @_;
356
357 # Always expect worst case!
358 my $status = -1;
359 eval {
d41516b2 360 my @stats = ();
fc7ec1d9 361 my $handler = sub {
fee92828 362 my $c = $class->prepare($r);
d41516b2 363 $c->{stats} = \@stats;
eb9ff8f4 364 my $action = $c->req->action;
365 my $namespace = '';
ac733264 366 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
367 if $action eq 'default';
eb9ff8f4 368 unless ($namespace) {
0169d3a8 369 if ( my $result = $c->get_action($action) ) {
eb9ff8f4 370 $namespace = _class2prefix( $result->[0]->[0]->[0] );
7833fdfc 371 }
87e67021 372 }
ac733264 373 my $default = $action eq 'default' ? $namespace : undef;
374 my $results = $c->get_action( $action, $default );
375 $namespace ||= '/';
b768faa3 376 if ( @{$results} ) {
ac733264 377 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
970cc51d 378 $c->state( $c->execute( @{ $begin->[0] } ) );
b768faa3 379 }
98dcf439 380 for my $result ( @{ $c->get_action( $action, $default ) }[-1] )
381 {
970cc51d 382 $c->state( $c->execute( @{ $result->[0] } ) );
ac733264 383 last unless $default;
b768faa3 384 }
98dcf439 385 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
386 {
970cc51d 387 $c->state( $c->execute( @{ $end->[0] } ) );
b768faa3 388 }
fc7ec1d9 389 }
390 else {
87e67021 391 my $path = $c->req->path;
392 my $error = $path
393 ? qq/Unknown resource "$path"/
7833fdfc 394 : "No default action defined";
fc7ec1d9 395 $c->log->error($error) if $c->debug;
a554cc3b 396 $c->error($error);
fc7ec1d9 397 }
398 return $c->finalize;
399 };
400 if ( $class->debug ) {
401 my $elapsed;
402 ( $elapsed, $status ) = $class->benchmark($handler);
403 $elapsed = sprintf '%f', $elapsed;
404 my $av = sprintf '%.3f', 1 / $elapsed;
d41516b2 405 $class->log->info( "Request took $elapsed" . "s ($av/s)", @stats );
fc7ec1d9 406 }
407 else { $status = &$handler }
408 };
409 if ( my $error = $@ ) {
410 chomp $error;
411 $class->log->error(qq/Caught exception in engine "$error"/);
412 }
413 $COUNT++;
414 return $status;
415}
416
23f9d934 417=item $c->prepare($r)
fc7ec1d9 418
a554cc3b 419Turns the engine-specific request( Apache, CGI ... )
420into a Catalyst context .
fc7ec1d9 421
422=cut
423
424sub prepare {
425 my ( $class, $r ) = @_;
426 my $c = bless {
427 request => Catalyst::Request->new(
428 {
429 arguments => [],
430 cookies => {},
431 headers => HTTP::Headers->new,
432 parameters => {},
433 snippets => [],
434 uploads => {}
435 }
436 ),
437 response => Catalyst::Response->new(
438 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
439 ),
b768faa3 440 stash => {},
441 state => 0
fc7ec1d9 442 }, $class;
443 if ( $c->debug ) {
444 my $secs = time - $START || 1;
445 my $av = sprintf '%.3f', $COUNT / $secs;
446 $c->log->debug('********************************');
447 $c->log->debug("* Request $COUNT ($av/s) [$$]");
448 $c->log->debug('********************************');
449 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
450 }
451 $c->prepare_request($r);
452 $c->prepare_path;
ac733264 453 $c->prepare_headers;
1a80619d 454 $c->prepare_cookies;
0556eb49 455 $c->prepare_connection;
456 my $method = $c->req->method || '';
457 my $path = $c->req->path || '';
458 my $hostname = $c->req->hostname || '';
459 my $address = $c->req->address || '';
460 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
461 if $c->debug;
fc7ec1d9 462 $c->prepare_action;
463 $c->prepare_parameters;
c85ff642 464
465 if ( $c->debug && keys %{ $c->req->params } ) {
466 my @params;
467 for my $key ( keys %{ $c->req->params } ) {
b5524568 468 my $value = $c->req->params->{$key} || '';
32e4cad6 469 push @params, " $key=$value";
c85ff642 470 }
3dafb279 471 $c->log->debug( 'Parameters are', @params );
c85ff642 472 }
fc7ec1d9 473 $c->prepare_uploads;
474 return $c;
475}
476
23f9d934 477=item $c->prepare_action
fc7ec1d9 478
479Prepare action.
480
481=cut
482
483sub prepare_action {
484 my $c = shift;
485 my $path = $c->req->path;
486 my @path = split /\//, $c->req->path;
487 $c->req->args( \my @args );
488 while (@path) {
7833fdfc 489 $path = join '/', @path;
0169d3a8 490 if ( my $result = ${ $c->get_action($path) }[0] ) {
fc7ec1d9 491
492 # It's a regex
493 if ($#$result) {
7e5adedd 494 my $match = $result->[1];
495 my @snippets = @{ $result->[2] };
fc7ec1d9 496 $c->log->debug(qq/Requested action "$path" matched "$match"/)
497 if $c->debug;
498 $c->log->debug(
499 'Snippets are "' . join( ' ', @snippets ) . '"' )
500 if ( $c->debug && @snippets );
501 $c->req->action($match);
502 $c->req->snippets( \@snippets );
503 }
504 else {
505 $c->req->action($path);
506 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
507 }
508 $c->req->match($path);
fc7ec1d9 509 last;
510 }
511 unshift @args, pop @path;
512 }
513 unless ( $c->req->action ) {
ac733264 514 $c->req->action('default');
87e67021 515 $c->req->match('');
fc7ec1d9 516 }
5783a9a5 517 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
518 if ( $c->debug && @args );
fc7ec1d9 519}
520
c9afa5fc 521=item $c->prepare_connection
0556eb49 522
523Prepare connection.
524
525=cut
526
527sub prepare_connection { }
528
c9afa5fc 529=item $c->prepare_cookies
fc7ec1d9 530
531Prepare cookies.
532
533=cut
534
535sub prepare_cookies { }
536
23f9d934 537=item $c->prepare_headers
fc7ec1d9 538
539Prepare headers.
540
541=cut
542
543sub prepare_headers { }
544
23f9d934 545=item $c->prepare_parameters
fc7ec1d9 546
547Prepare parameters.
548
549=cut
550
551sub prepare_parameters { }
552
23f9d934 553=item $c->prepare_path
fc7ec1d9 554
555Prepare path and base.
556
557=cut
558
559sub prepare_path { }
560
23f9d934 561=item $c->prepare_request
fc7ec1d9 562
563Prepare the engine request.
564
565=cut
566
567sub prepare_request { }
568
23f9d934 569=item $c->prepare_uploads
fc7ec1d9 570
571Prepare uploads.
572
573=cut
574
575sub prepare_uploads { }
576
970cc51d 577=item $c->execute($class, $coderef)
fc7ec1d9 578
970cc51d 579Execute a coderef in given class and catch exceptions.
a554cc3b 580Errors are available via $c->error.
fc7ec1d9 581
582=cut
583
970cc51d 584sub execute {
fc7ec1d9 585 my ( $c, $class, $code ) = @_;
a554cc3b 586 $class = $c->comp($class) || $class;
587 $c->state(0);
fc7ec1d9 588 eval {
589 if ( $c->debug )
590 {
fee92828 591 my $action = $c->actions->{reverse}->{"$code"};
592 $action = "/$action" unless $action =~ /\-\>/;
a554cc3b 593 my ( $elapsed, @state ) =
fc7ec1d9 594 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
fee92828 595 push @{ $c->{stats} },
b5c7bbe3 596 _prettify( $action, sprintf( '%fs', $elapsed ), '' );
a554cc3b 597 $c->state(@state);
fc7ec1d9 598 }
a554cc3b 599 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
fc7ec1d9 600 };
601 if ( my $error = $@ ) {
602 chomp $error;
603 $error = qq/Caught exception "$error"/;
604 $c->log->error($error);
a554cc3b 605 $c->error($error) if $c->debug;
606 $c->state(0);
fc7ec1d9 607 }
a554cc3b 608 return $c->state;
fc7ec1d9 609}
610
c9afa5fc 611=item $c->run
612
613Starts the engine.
614
615=cut
616
617sub run { }
618
23f9d934 619=item $c->request
620
621=item $c->req
fc7ec1d9 622
623Returns a C<Catalyst::Request> object.
624
625 my $req = $c->req;
626
23f9d934 627=item $c->response
628
629=item $c->res
fc7ec1d9 630
631Returns a C<Catalyst::Response> object.
632
633 my $res = $c->res;
634
ac733264 635=item $c->set_action( $action, $code, $namespace, $attrs )
66d9e175 636
637Set an action in a given namespace.
638
639=cut
640
641sub set_action {
ac733264 642 my ( $c, $method, $code, $namespace, $attrs ) = @_;
643
6372237c 644 my $prefix = _class2prefix($namespace) || '';
645 my %flags;
ac733264 646
647 for my $attr ( @{$attrs} ) {
98dcf439 648 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
649 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
650 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
651 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
1d4ea19d 652 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
66d9e175 653 }
ac733264 654
6372237c 655 return unless keys %flags;
ac733264 656
657 my $parent = $c->tree;
658 my $visitor = Tree::Simple::Visitor::FindByPath->new;
659 for my $part ( split '/', $prefix ) {
660 $visitor->setSearchPath($part);
661 $parent->accept($visitor);
662 my $child = $visitor->getResult;
663 unless ($child) {
664 $child = $parent->addChild( Tree::Simple->new($part) );
66d9e175 665 $visitor->setSearchPath($part);
666 $parent->accept($visitor);
ac733264 667 $child = $visitor->getResult;
66d9e175 668 }
ac733264 669 $parent = $child;
66d9e175 670 }
ac733264 671 my $uid = $parent->getUID;
672 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
673 my $forward = $prefix ? "$prefix/$method" : $method;
ac733264 674
6372237c 675 if ( $flags{path} ) {
676 $flags{path} =~ s/^\w+//;
677 $flags{path} =~ s/\w+$//;
678 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
679 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
680 }
681 if ( $flags{regex} ) {
682 $flags{regex} =~ s/^\w+//;
683 $flags{regex} =~ s/\w+$//;
684 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
685 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
686 }
ac733264 687
fee92828 688 my $reverse = $prefix ? "$prefix/$method" : $method;
ac733264 689
6372237c 690 if ( $flags{local} || $flags{global} || $flags{path} ) {
691 my $path = $flags{path} || $method;
692 my $absolute = 0;
693 if ( $path =~ /^\/(.+)/ ) {
694 $path = $1;
695 $absolute = 1;
ac733264 696 }
8702d594 697 $absolute = 1 if $flags{global};
6372237c 698 my $name = $absolute ? $path : "$prefix/$path";
ac733264 699 $c->actions->{plain}->{$name} = [ $namespace, $code ];
ac733264 700 }
6372237c 701 if ( my $regex = $flags{regex} ) {
702 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
703 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
ac733264 704 }
705
706 $c->actions->{reverse}->{"$code"} = $reverse;
66d9e175 707}
708
23f9d934 709=item $class->setup
fc7ec1d9 710
711Setup.
712
713 MyApp->setup;
714
715=cut
716
717sub setup {
718 my $self = shift;
719 $self->setup_components;
720 if ( $self->debug ) {
721 my $name = $self->config->{name} || 'Application';
722 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
723 }
724}
725
ac733264 726=item $class->setup_actions($component)
727
728Setup actions for a component.
729
730=cut
731
732sub setup_actions {
733 my ( $self, $comp ) = @_;
734 $comp = ref $comp || $comp;
735 for my $action ( @{ $comp->_cache } ) {
736 my ( $code, $attrs ) = @{$action};
737 my $name = '';
738 no strict 'refs';
98dcf439 739 my @cache = ( $comp, @{"$comp\::ISA"} );
bb6823f2 740 my %namespaces;
98dcf439 741 while ( my $namespace = shift @cache ) {
bb6823f2 742 $namespaces{$namespace}++;
98dcf439 743 for my $isa ( @{"$comp\::ISA"} ) {
bb6823f2 744 next if $namespaces{$isa};
98dcf439 745 push @cache, $isa;
bb6823f2 746 $namespaces{$isa}++;
98dcf439 747 }
748 }
bb6823f2 749 for my $namespace ( keys %namespaces ) {
98dcf439 750 for my $sym ( values %{ $namespace . '::' } ) {
751 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
752 $name = *{$sym}{NAME};
753 $self->set_action( $name, $code, $comp, $attrs );
754 last;
755 }
ac733264 756 }
757 }
758 }
759}
760
23f9d934 761=item $class->setup_components
fc7ec1d9 762
763Setup components.
764
765=cut
766
767sub setup_components {
768 my $self = shift;
769
770 # Components
771 my $class = ref $self || $self;
772 eval <<"";
773 package $class;
774 import Module::Pluggable::Fast
775 name => '_components',
776 search => [
777 '$class\::Controller', '$class\::C',
778 '$class\::Model', '$class\::M',
779 '$class\::View', '$class\::V'
780 ];
781
782 if ( my $error = $@ ) {
783 chomp $error;
784 $self->log->error(
785 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
786 }
ac733264 787 $self->setup_actions($self);
fc7ec1d9 788 $self->components( {} );
ac733264 789 for my $comp ( $self->_components($self) ) {
790 $self->components->{ ref $comp } = $comp;
791 $self->setup_actions($comp);
fc7ec1d9 792 }
af2ad181 793 my @comps;
32e4cad6 794 push @comps, " $_" for keys %{ $self->components };
4cf083b1 795 $self->log->debug( 'Loaded components', @comps )
796 if ( @comps && $self->debug );
797 my $actions = $self->actions;
798 my @messages = ('Loaded private actions');
799 my $walker = sub {
800 my ( $walker, $parent, $messages, $prefix ) = @_;
801 $prefix .= $parent->getNodeValue || '';
802 $prefix .= '/' unless $prefix =~ /\/$/;
803 my $uid = $parent->getUID;
804 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
805 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
af2ad181 806 push @$messages, _prettify( "$prefix$action", $class, $code );
4cf083b1 807 }
808 $walker->( $walker, $_, $messages, $prefix )
809 for $parent->getAllChildren;
810 };
811 $walker->( $walker, $self->tree, \@messages, '' );
812 $self->log->debug(@messages) if ( $#messages && $self->debug );
813 @messages = ('Loaded plain actions');
6655e7d4 814 for my $plain ( sort keys %{ $actions->{plain} } ) {
4cf083b1 815 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
92a3f2c9 816 push @messages, _prettify( "/$plain", $class, $code );
4cf083b1 817 }
818 $self->log->debug(@messages) if ( $#messages && $self->debug );
819 @messages = ('Loaded regex actions');
6655e7d4 820 for my $regex ( sort keys %{ $actions->{regex} } ) {
4cf083b1 821 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
af2ad181 822 push @messages, _prettify( $regex, $class, $code );
4cf083b1 823 }
824 $self->log->debug(@messages) if ( $#messages && $self->debug );
fc7ec1d9 825}
826
23f9d934 827=item $c->stash
fc7ec1d9 828
829Returns a hashref containing all your data.
830
831 $c->stash->{foo} ||= 'yada';
832 print $c->stash->{foo};
833
834=cut
835
836sub stash {
837 my $self = shift;
838 if ( $_[0] ) {
839 my $stash = $_[1] ? {@_} : $_[0];
840 while ( my ( $key, $val ) = each %$stash ) {
841 $self->{stash}->{$key} = $val;
842 }
843 }
844 return $self->{stash};
845}
846
847sub _prefix {
848 my ( $class, $name ) = @_;
7833fdfc 849 my $prefix = _class2prefix($class);
850 $name = "$prefix/$name" if $prefix;
851 return $name;
852}
853
854sub _class2prefix {
b768faa3 855 my $class = shift || '';
0434eec1 856 my $prefix;
98dcf439 857 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
858 $prefix = lc $2;
859 $prefix =~ s/\:\:/\//g;
0434eec1 860 }
7833fdfc 861 return $prefix;
fc7ec1d9 862}
863
af2ad181 864sub _prettify {
fee92828 865 my ( $val1, $val2, $val3 ) = @_;
af2ad181 866 formline
b5c7bbe3 867' @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>> ',
fee92828 868 $val1, $val2, $val3;
af2ad181 869 my $formatted = $^A;
870 $^A = '';
871 return $formatted;
872}
873
23f9d934 874=back
875
fc7ec1d9 876=head1 AUTHOR
877
878Sebastian Riedel, C<sri@cpan.org>
879
880=head1 COPYRIGHT
881
882This program is free software, you can redistribute it and/or modify it under
883the same terms as Perl itself.
884
885=cut
886
8871;
The Perl MVC Framework (catagits@git.shadowcat.co.uk:Catalyst-Runtime.git)