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