projects / catagits/Catalyst-Runtime.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Updated to new structure
[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} || '';
c85ff642 467 push @params, "$key=$value";
468 }
469 $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
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;
671 $c->log->debug(qq|Private "/$forward" is "$namespace->$method"|)
a554cc3b 672 if $c->debug;
ac733264 673
6372237c 674 if ( $flags{path} ) {
675 $flags{path} =~ s/^\w+//;
676 $flags{path} =~ s/\w+$//;
677 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
678 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
679 }
680 if ( $flags{regex} ) {
681 $flags{regex} =~ s/^\w+//;
682 $flags{regex} =~ s/\w+$//;
683 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
684 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
685 }
ac733264 686
687 my $reverse = $prefix ? "$method ($prefix)" : $method;
688
6372237c 689 if ( $flags{local} || $flags{global} || $flags{path} ) {
690 my $path = $flags{path} || $method;
691 my $absolute = 0;
692 if ( $path =~ /^\/(.+)/ ) {
693 $path = $1;
694 $absolute = 1;
ac733264 695 }
8702d594 696 $absolute = 1 if $flags{global};
6372237c 697 my $name = $absolute ? $path : "$prefix/$path";
ac733264 698 $c->actions->{plain}->{$name} = [ $namespace, $code ];
699 $c->log->debug(qq|Public "/$name" is "/$forward"|) if $c->debug;
700 }
6372237c 701 if ( my $regex = $flags{regex} ) {
702 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
703 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
704 $c->log->debug(qq|Public "$regex" is "/$forward"|) if $c->debug;
ac733264 705 }
706
707 $c->actions->{reverse}->{"$code"} = $reverse;
66d9e175 708}
709
23f9d934 710=item $class->setup
fc7ec1d9 711
712Setup.
713
714 MyApp->setup;
715
716=cut
717
718sub setup {
719 my $self = shift;
720 $self->setup_components;
721 if ( $self->debug ) {
722 my $name = $self->config->{name} || 'Application';
723 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
724 }
725}
726
ac733264 727=item $class->setup_actions($component)
728
729Setup actions for a component.
730
731=cut
732
733sub setup_actions {
734 my ( $self, $comp ) = @_;
735 $comp = ref $comp || $comp;
736 for my $action ( @{ $comp->_cache } ) {
737 my ( $code, $attrs ) = @{$action};
738 my $name = '';
739 no strict 'refs';
98dcf439 740 my @cache = ( $comp, @{"$comp\::ISA"} );
741 my @namespaces;
742 my %seen;
743 while ( my $namespace = shift @cache ) {
744 push @namespaces, $namespace;
745 for my $isa ( @{"$comp\::ISA"} ) {
746 next if $seen{$isa};
747 push @cache, $isa;
748 $seen{$isa}++;
749 }
750 }
751 for my $namespace (@namespaces) {
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 }
795 $self->log->debug( 'Initialized components "'
796 . join( ' ', keys %{ $self->components } )
797 . '"' )
798 if $self->debug;
799}
800
23f9d934 801=item $c->stash
fc7ec1d9 802
803Returns a hashref containing all your data.
804
805 $c->stash->{foo} ||= 'yada';
806 print $c->stash->{foo};
807
808=cut
809
810sub stash {
811 my $self = shift;
812 if ( $_[0] ) {
813 my $stash = $_[1] ? {@_} : $_[0];
814 while ( my ( $key, $val ) = each %$stash ) {
815 $self->{stash}->{$key} = $val;
816 }
817 }
818 return $self->{stash};
819}
820
821sub _prefix {
822 my ( $class, $name ) = @_;
7833fdfc 823 my $prefix = _class2prefix($class);
824 $name = "$prefix/$name" if $prefix;
825 return $name;
826}
827
828sub _class2prefix {
b768faa3 829 my $class = shift || '';
0434eec1 830 my $prefix;
98dcf439 831 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
832 $prefix = lc $2;
833 $prefix =~ s/\:\:/\//g;
0434eec1 834 }
7833fdfc 835 return $prefix;
fc7ec1d9 836}
837
23f9d934 838=back
839
fc7ec1d9 840=head1 AUTHOR
841
842Sebastian Riedel, C<sri@cpan.org>
843
844=head1 COPYRIGHT
845
846This program is free software, you can redistribute it and/or modify it under
847the same terms as Perl itself.
848
849=cut
850
8511;
The Perl MVC Framework (catagits@git.shadowcat.co.uk:Catalyst-Runtime.git)