projects / catagits/Catalyst-Runtime.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
some formatting
[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 {
eb9ff8f4 361 my $c = $class->prepare($r);
362 my $action = $c->req->action;
363 my $namespace = '';
ac733264 364 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
365 if $action eq 'default';
eb9ff8f4 366 unless ($namespace) {
0169d3a8 367 if ( my $result = $c->get_action($action) ) {
eb9ff8f4 368 $namespace = _class2prefix( $result->[0]->[0]->[0] );
7833fdfc 369 }
87e67021 370 }
ac733264 371 my $default = $action eq 'default' ? $namespace : undef;
372 my $results = $c->get_action( $action, $default );
373 $namespace ||= '/';
b768faa3 374 if ( @{$results} ) {
ac733264 375 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
970cc51d 376 $c->state( $c->execute( @{ $begin->[0] } ) );
b768faa3 377 }
98dcf439 378 for my $result ( @{ $c->get_action( $action, $default ) }[-1] )
379 {
970cc51d 380 $c->state( $c->execute( @{ $result->[0] } ) );
ac733264 381 last unless $default;
b768faa3 382 }
98dcf439 383 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
384 {
970cc51d 385 $c->state( $c->execute( @{ $end->[0] } ) );
b768faa3 386 }
fc7ec1d9 387 }
388 else {
87e67021 389 my $path = $c->req->path;
390 my $error = $path
391 ? qq/Unknown resource "$path"/
7833fdfc 392 : "No default action defined";
fc7ec1d9 393 $c->log->error($error) if $c->debug;
a554cc3b 394 $c->error($error);
fc7ec1d9 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
23f9d934 415=item $c->prepare($r)
fc7ec1d9 416
a554cc3b 417Turns the engine-specific request( Apache, CGI ... )
418into a Catalyst context .
fc7ec1d9 419
420=cut
421
422sub 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 ),
b768faa3 438 stash => {},
439 state => 0
fc7ec1d9 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;
ac733264 451 $c->prepare_headers;
1a80619d 452 $c->prepare_cookies;
0556eb49 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;
fc7ec1d9 460 $c->prepare_action;
461 $c->prepare_parameters;
c85ff642 462
463 if ( $c->debug && keys %{ $c->req->params } ) {
464 my @params;
465 for my $key ( keys %{ $c->req->params } ) {
b5524568 466 my $value = $c->req->params->{$key} || '';
af2ad181 467 push @params, " $key=$value";
c85ff642 468 }
af2ad181 469 $c->log->debug( 'Parameters', @params );
c85ff642 470 }
fc7ec1d9 471 $c->prepare_uploads;
472 return $c;
473}
474
23f9d934 475=item $c->prepare_action
fc7ec1d9 476
477Prepare action.
478
479=cut
480
481sub 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) {
7833fdfc 487 $path = join '/', @path;
0169d3a8 488 if ( my $result = ${ $c->get_action($path) }[0] ) {
fc7ec1d9 489
490 # It's a regex
491 if ($#$result) {
7e5adedd 492 my $match = $result->[1];
493 my @snippets = @{ $result->[2] };
fc7ec1d9 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);
fc7ec1d9 507 last;
508 }
509 unshift @args, pop @path;
510 }
511 unless ( $c->req->action ) {
ac733264 512 $c->req->action('default');
87e67021 513 $c->req->match('');
fc7ec1d9 514 }
5783a9a5 515 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
516 if ( $c->debug && @args );
fc7ec1d9 517}
518
c9afa5fc 519=item $c->prepare_connection
0556eb49 520
521Prepare connection.
522
523=cut
524
525sub prepare_connection { }
526
c9afa5fc 527=item $c->prepare_cookies
fc7ec1d9 528
529Prepare cookies.
530
531=cut
532
533sub prepare_cookies { }
534
23f9d934 535=item $c->prepare_headers
fc7ec1d9 536
537Prepare headers.
538
539=cut
540
541sub prepare_headers { }
542
23f9d934 543=item $c->prepare_parameters
fc7ec1d9 544
545Prepare parameters.
546
547=cut
548
549sub prepare_parameters { }
550
23f9d934 551=item $c->prepare_path
fc7ec1d9 552
553Prepare path and base.
554
555=cut
556
557sub prepare_path { }
558
23f9d934 559=item $c->prepare_request
fc7ec1d9 560
561Prepare the engine request.
562
563=cut
564
565sub prepare_request { }
566
23f9d934 567=item $c->prepare_uploads
fc7ec1d9 568
569Prepare uploads.
570
571=cut
572
573sub prepare_uploads { }
574
970cc51d 575=item $c->execute($class, $coderef)
fc7ec1d9 576
970cc51d 577Execute a coderef in given class and catch exceptions.
a554cc3b 578Errors are available via $c->error.
fc7ec1d9 579
580=cut
581
970cc51d 582sub execute {
fc7ec1d9 583 my ( $c, $class, $code ) = @_;
a554cc3b 584 $class = $c->comp($class) || $class;
585 $c->state(0);
fc7ec1d9 586 eval {
587 if ( $c->debug )
588 {
589 my $action = $c->actions->{reverse}->{"$code"} || "$code";
a554cc3b 590 my ( $elapsed, @state ) =
fc7ec1d9 591 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
592 $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
593 if $c->debug;
a554cc3b 594 $c->state(@state);
fc7ec1d9 595 }
a554cc3b 596 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
fc7ec1d9 597 };
598 if ( my $error = $@ ) {
599 chomp $error;
600 $error = qq/Caught exception "$error"/;
601 $c->log->error($error);
a554cc3b 602 $c->error($error) if $c->debug;
603 $c->state(0);
fc7ec1d9 604 }
a554cc3b 605 return $c->state;
fc7ec1d9 606}
607
c9afa5fc 608=item $c->run
609
610Starts the engine.
611
612=cut
613
614sub run { }
615
23f9d934 616=item $c->request
617
618=item $c->req
fc7ec1d9 619
620Returns a C<Catalyst::Request> object.
621
622 my $req = $c->req;
623
23f9d934 624=item $c->response
625
626=item $c->res
fc7ec1d9 627
628Returns a C<Catalyst::Response> object.
629
630 my $res = $c->res;
631
ac733264 632=item $c->set_action( $action, $code, $namespace, $attrs )
66d9e175 633
634Set an action in a given namespace.
635
636=cut
637
638sub set_action {
ac733264 639 my ( $c, $method, $code, $namespace, $attrs ) = @_;
640
6372237c 641 my $prefix = _class2prefix($namespace) || '';
642 my %flags;
ac733264 643
644 for my $attr ( @{$attrs} ) {
98dcf439 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}++ }
1d4ea19d 649 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
66d9e175 650 }
ac733264 651
6372237c 652 return unless keys %flags;
ac733264 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) );
66d9e175 662 $visitor->setSearchPath($part);
663 $parent->accept($visitor);
ac733264 664 $child = $visitor->getResult;
66d9e175 665 }
ac733264 666 $parent = $child;
66d9e175 667 }
ac733264 668 my $uid = $parent->getUID;
669 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
670 my $forward = $prefix ? "$prefix/$method" : $method;
ac733264 671
6372237c 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 }
ac733264 684
685 my $reverse = $prefix ? "$method ($prefix)" : $method;
686
6372237c 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;
ac733264 693 }
8702d594 694 $absolute = 1 if $flags{global};
6372237c 695 my $name = $absolute ? $path : "$prefix/$path";
ac733264 696 $c->actions->{plain}->{$name} = [ $namespace, $code ];
ac733264 697 }
6372237c 698 if ( my $regex = $flags{regex} ) {
699 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
700 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
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';
98dcf439 736 my @cache = ( $comp, @{"$comp\::ISA"} );
bb6823f2 737 my %namespaces;
98dcf439 738 while ( my $namespace = shift @cache ) {
bb6823f2 739 $namespaces{$namespace}++;
98dcf439 740 for my $isa ( @{"$comp\::ISA"} ) {
bb6823f2 741 next if $namespaces{$isa};
98dcf439 742 push @cache, $isa;
bb6823f2 743 $namespaces{$isa}++;
98dcf439 744 }
745 }
bb6823f2 746 for my $namespace ( keys %namespaces ) {
98dcf439 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 }
ac733264 753 }
754 }
755 }
756}
757
23f9d934 758=item $class->setup_components
fc7ec1d9 759
760Setup components.
761
762=cut
763
764sub 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 }
ac733264 784 $self->setup_actions($self);
fc7ec1d9 785 $self->components( {} );
ac733264 786 for my $comp ( $self->_components($self) ) {
787 $self->components->{ ref $comp } = $comp;
788 $self->setup_actions($comp);
fc7ec1d9 789 }
af2ad181 790 my @comps;
791 push @comps, " $_" for keys %{ $self->components };
4cf083b1 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} };
af2ad181 803 push @$messages, _prettify( "$prefix$action", $class, $code );
4cf083b1 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 ( keys %{ $actions->{plain} } ) {
812 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
af2ad181 813 push @messages, _prettify( $plain, $class, $code );
4cf083b1 814 }
815 $self->log->debug(@messages) if ( $#messages && $self->debug );
816 @messages = ('Loaded regex actions');
817 for my $regex ( keys %{ $actions->{regex} } ) {
818 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
af2ad181 819 push @messages, _prettify( $regex, $class, $code );
4cf083b1 820 }
821 $self->log->debug(@messages) if ( $#messages && $self->debug );
fc7ec1d9 822}
823
23f9d934 824=item $c->stash
fc7ec1d9 825
826Returns a hashref containing all your data.
827
828 $c->stash->{foo} ||= 'yada';
829 print $c->stash->{foo};
830
831=cut
832
833sub 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
844sub _prefix {
845 my ( $class, $name ) = @_;
7833fdfc 846 my $prefix = _class2prefix($class);
847 $name = "$prefix/$name" if $prefix;
848 return $name;
849}
850
851sub _class2prefix {
b768faa3 852 my $class = shift || '';
0434eec1 853 my $prefix;
98dcf439 854 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
855 $prefix = lc $2;
856 $prefix =~ s/\:\:/\//g;
0434eec1 857 }
7833fdfc 858 return $prefix;
fc7ec1d9 859}
860
af2ad181 861sub _prettify {
862 my ( $action, $class, $code ) = @_;
863 formline
864' @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @|||||||||||||| ',
865 $action, $class, $code;
866 my $formatted = $^A;
867 $^A = '';
868 return $formatted;
869}
870
23f9d934 871=back
872
fc7ec1d9 873=head1 AUTHOR
874
875Sebastian Riedel, C<sri@cpan.org>
876
877=head1 COPYRIGHT
878
879This program is free software, you can redistribute it and/or modify it under
880the same terms as Perl itself.
881
882=cut
883
8841;
The Perl MVC Framework (catagits@git.shadowcat.co.uk:Catalyst-Runtime.git)