DWIM continuation statistics
[catagits/Catalyst-Runtime.git] / lib / Catalyst.pm
CommitLineData
fc7ec1d9 1package Catalyst;
2
3use strict;
31375184 4use base 'Catalyst::Component';
fbcc39ad 5use bytes;
fc7ec1d9 6use UNIVERSAL::require;
a2f2cde9 7use Catalyst::Exception;
fc7ec1d9 8use Catalyst::Log;
fbcc39ad 9use Catalyst::Request;
10use Catalyst::Request::Upload;
11use Catalyst::Response;
812a28c9 12use Catalyst::Utils;
31375184 13use Catalyst::Controller;
8f62c91a 14use File::stat;
5d9a6d47 15use NEXT;
8c113188 16use Text::SimpleTable;
a738ab68 17use Path::Class::Dir;
18use Path::Class::File;
fbcc39ad 19use Time::HiRes qw/gettimeofday tv_interval/;
20use URI;
6a4a7002 21use Scalar::Util qw/weaken blessed/;
5513038d 22use Tree::Simple qw/use_weak_refs/;
23use Tree::Simple::Visitor::FindByUID;
261c571e 24use attributes;
5789a3d8 25use utf8;
9ce44430 26use Carp qw/croak/;
fc7ec1d9 27
66e28e3f 28__PACKAGE__->mk_accessors(
7a7d7af5 29 qw/counter request response state action stack namespace stats/
66e28e3f 30);
10dd6896 31
684d10ed 32attributes->import( __PACKAGE__, \&namespace, 'lvalue' );
261c571e 33
8767c5a3 34sub depth { scalar @{ shift->stack || [] }; }
28591cd7 35
fbcc39ad 36# Laziness++
37*comp = \&component;
38*req = \&request;
39*res = \&response;
40
41# For backwards compatibility
42*finalize_output = \&finalize_body;
43
44# For statistics
45our $COUNT = 1;
46our $START = time;
47our $RECURSION = 1000;
48our $DETACH = "catalyst_detach\n";
49
50require Module::Pluggable::Fast;
51
52# Helper script generation
92ffbc90 53our $CATALYST_SCRIPT_GEN = 27;
fbcc39ad 54
55__PACKAGE__->mk_classdata($_)
3cec521a 56 for qw/components arguments dispatcher engine log dispatcher_class
3643e890 57 engine_class context_class request_class response_class setup_finished/;
cb0354c6 58
3cec521a 59__PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
60__PACKAGE__->engine_class('Catalyst::Engine::CGI');
61__PACKAGE__->request_class('Catalyst::Request');
62__PACKAGE__->response_class('Catalyst::Response');
fbcc39ad 63
97b58e17 64our $VERSION = '5.66';
189e2a51 65
fbcc39ad 66sub import {
67 my ( $class, @arguments ) = @_;
68
69 # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
70 # callers @ISA.
71 return unless $class eq 'Catalyst';
72
73 my $caller = caller(0);
74
75 unless ( $caller->isa('Catalyst') ) {
76 no strict 'refs';
31375184 77 push @{"$caller\::ISA"}, $class, 'Catalyst::Controller';
fbcc39ad 78 }
79
80 $caller->arguments( [@arguments] );
81 $caller->setup_home;
82}
fc7ec1d9 83
84=head1 NAME
85
86Catalyst - The Elegant MVC Web Application Framework
87
88=head1 SYNOPSIS
89
90 # use the helper to start a new application
91864987 91 catalyst.pl MyApp
fc7ec1d9 92
93 # add models, views, controllers
0ef52a96 94 script/myapp_create.pl model Database DBIC dbi:SQLite:/path/to/db
95 script/myapp_create.pl view TT TT
96 script/myapp_create.pl controller Search
fc7ec1d9 97
e7f1cf73 98 # built in testserver -- use -r to restart automatically on changes
ae4e40a7 99 script/myapp_server.pl
fc7ec1d9 100
0ef52a96 101 # command line testing interface
ae4e40a7 102 script/myapp_test.pl /yada
fc7ec1d9 103
0ef52a96 104 ### in MyApp.pm
105 use Catalyst qw/-Debug/; # include plugins here as well
106
107 sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc.
ae1e6b59 108 my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2
109 $c->stash->{template} = 'foo.tt'; # set the template
0ef52a96 110 # lookup something from db -- stash vars are passed to TT
ae1e6b59 111 $c->stash->{data} =
112 MyApp::Model::Database::Foo->search( { country => $args[0] } );
0ef52a96 113 if ( $c->req->params->{bar} ) { # access GET or POST parameters
114 $c->forward( 'bar' ); # process another action
115 # do something else after forward returns
116 }
117 }
118
ae1e6b59 119 # The foo.tt TT template can use the stash data from the database
0ef52a96 120 [% WHILE (item = data.next) %]
121 [% item.foo %]
122 [% END %]
123
124 # called for /bar/of/soap, /bar/of/soap/10, etc.
125 sub bar : Path('/bar/of/soap') { ... }
fc7ec1d9 126
ae1e6b59 127 # called for all actions, from the top-most controller downwards
0ef52a96 128 sub auto : Private {
129 my ( $self, $c ) = @_;
130 if ( !$c->user ) {
131 $c->res->redirect( '/login' ); # require login
132 return 0; # abort request and go immediately to end()
133 }
ae1e6b59 134 return 1; # success; carry on to next action
0ef52a96 135 }
136
ae1e6b59 137 # called after all actions are finished
0ef52a96 138 sub end : Private {
5a8ed4fe 139 my ( $self, $c ) = @_;
0ef52a96 140 if ( scalar @{ $c->error } ) { ... } # handle errors
141 return if $c->res->body; # already have a response
142 $c->forward( 'MyApp::View::TT' ); # render template
5a8ed4fe 143 }
144
0ef52a96 145 ### in MyApp/Controller/Foo.pm
146 # called for /foo/bar
147 sub bar : Local { ... }
148
5400c668 149 # called for /blargle
150 sub blargle : Global { ... }
151
152 # an index action matches /foo, but not /foo/1, etc.
153 sub index : Private { ... }
0ef52a96 154
155 ### in MyApp/Controller/Foo/Bar.pm
156 # called for /foo/bar/baz
157 sub baz : Local { ... }
158
159 # first MyApp auto is called, then Foo auto, then this
160 sub auto : Private { ... }
161
162 # powerful regular expression paths are also possible
163 sub details : Regex('^product/(\w+)/details$') {
5a8ed4fe 164 my ( $self, $c ) = @_;
0ef52a96 165 # extract the (\w+) from the URI
166 my $product = $c->req->snippets->[0];
5a8ed4fe 167 }
fc7ec1d9 168
0ef52a96 169See L<Catalyst::Manual::Intro> for additional information.
3803e98f 170
fc7ec1d9 171=head1 DESCRIPTION
172
fc7ec1d9 173The key concept of Catalyst is DRY (Don't Repeat Yourself).
174
175See L<Catalyst::Manual> for more documentation.
176
ae1e6b59 177Catalyst plugins can be loaded by naming them as arguments to the "use
178Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
179plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
180C<My::Module>.
fc7ec1d9 181
0ef52a96 182 use Catalyst qw/My::Module/;
fc7ec1d9 183
836e1134 184If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
185fully qualify the name by using a unary plus:
186
187 use Catalyst qw/
188 My::Module
189 +Fully::Qualified::Plugin::Name
190 /;
191
ae1e6b59 192Special flags like C<-Debug> and C<-Engine> can also be specified as
193arguments when Catalyst is loaded:
fc7ec1d9 194
195 use Catalyst qw/-Debug My::Module/;
196
ae1e6b59 197The position of plugins and flags in the chain is important, because
198they are loaded in exactly the order in which they appear.
fc7ec1d9 199
23f9d934 200The following flags are supported:
201
b5ecfcf0 202=head2 -Debug
23f9d934 203
0ef52a96 204Enables debug output.
fc7ec1d9 205
b5ecfcf0 206=head2 -Engine
fc7ec1d9 207
ae1e6b59 208Forces Catalyst to use a specific engine. Omit the
209C<Catalyst::Engine::> prefix of the engine name, i.e.:
fc7ec1d9 210
0ef52a96 211 use Catalyst qw/-Engine=CGI/;
fc7ec1d9 212
b5ecfcf0 213=head2 -Home
fbcc39ad 214
ae1e6b59 215Forces Catalyst to use a specific home directory, e.g.:
216
217 use Catalyst qw[-Home=/usr/sri];
fbcc39ad 218
b5ecfcf0 219=head2 -Log
fbcc39ad 220
0ef52a96 221Specifies log level.
fbcc39ad 222
23f9d934 223=head1 METHODS
224
f7b672ef 225=head2 INFORMATION ABOUT THE CURRENT REQUEST
0ef52a96 226
b5ecfcf0 227=head2 $c->action
66e28e3f 228
ae1e6b59 229Returns a L<Catalyst::Action> object for the current action, which
230stringifies to the action name. See L<Catalyst::Action>.
0ef52a96 231
b5ecfcf0 232=head2 $c->namespace
0ef52a96 233
ae1e6b59 234Returns the namespace of the current action, i.e., the uri prefix
235corresponding to the controller of the current action. For example:
236
237 # in Controller::Foo::Bar
238 $c->namespace; # returns 'foo/bar';
0ef52a96 239
b5ecfcf0 240=head2 $c->request
0ef52a96 241
b5ecfcf0 242=head2 $c->req
0ef52a96 243
ae1e6b59 244Returns the current L<Catalyst::Request> object. See
245L<Catalyst::Request>.
0ef52a96 246
f7b672ef 247=head2 PROCESSING AND RESPONSE TO THE CURRENT REQUEST
0ef52a96 248
b5ecfcf0 249=head2 $c->forward( $action [, \@arguments ] )
0ef52a96 250
b5ecfcf0 251=head2 $c->forward( $class, $method, [, \@arguments ] )
0ef52a96 252
ae1e6b59 253Forwards processing to a private action. If you give a class name but no
254method, C<process()> is called. You may also optionally pass arguments
255in an arrayref. The action will receive the arguments in C<@_> and
256C<$c-E<gt>req-E<gt>args>. Upon returning from the function,
257C<$c-E<gt>req-E<gt>args> will be restored to the previous values.
0ef52a96 258
3b984c64 259Any data C<return>ed from the action forwarded to, will be returned by the
d759db1e 260call to forward.
3b984c64 261
262 my $foodata = $c->forward('/foo');
0ef52a96 263 $c->forward('index');
e112461a 264 $c->forward(qw/MyApp::Model::DBIC::Foo do_stuff/);
0ef52a96 265 $c->forward('MyApp::View::TT');
266
267=cut
268
269sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
270
b5ecfcf0 271=head2 $c->detach( $action [, \@arguments ] )
0ef52a96 272
b5ecfcf0 273=head2 $c->detach( $class, $method, [, \@arguments ] )
0ef52a96 274
275The same as C<forward>, but doesn't return.
276
277=cut
278
279sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
280
b5ecfcf0 281=head2 $c->error
0ef52a96 282
b5ecfcf0 283=head2 $c->error($error, ...)
0ef52a96 284
b5ecfcf0 285=head2 $c->error($arrayref)
0ef52a96 286
83a8fcac 287Returns an arrayref containing error messages. If Catalyst encounters an
288error while processing a request, it stores the error in $c->error. This
289method should not be used to store non-fatal error messages.
0ef52a96 290
291 my @error = @{ $c->error };
292
293Add a new error.
294
295 $c->error('Something bad happened');
296
0ef52a96 297=cut
298
299sub error {
300 my $c = shift;
301 if ( $_[0] ) {
302 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
9ce44430 303 croak @$error unless ref $c;
0ef52a96 304 push @{ $c->{error} }, @$error;
305 }
306 elsif ( defined $_[0] ) { $c->{error} = undef }
307 return $c->{error} || [];
308}
309
ca81eb67 310=head2 $c->clear_errors
311
312Clear errors. You probably don't want to clear the errors unless you are
313implementing a custom error screen.
314
315This is equivalent to running
316
317 $c->error(0);
318
319=cut
320
321sub clear_errors {
322 my $c = shift;
323 $c->error(0);
324}
325
b5ecfcf0 326=head2 $c->response
0ef52a96 327
b5ecfcf0 328=head2 $c->res
0ef52a96 329
330Returns the current L<Catalyst::Response> object.
331
b5ecfcf0 332=head2 $c->stash
0ef52a96 333
ae1e6b59 334Returns a hashref to the stash, which may be used to store data and pass
335it between components during a request. You can also set hash keys by
336passing arguments. The stash is automatically sent to the view. The
337stash is cleared at the end of a request; it cannot be used for
338persistent storage.
0ef52a96 339
340 $c->stash->{foo} = $bar;
341 $c->stash( { moose => 'majestic', qux => 0 } );
342 $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
343
344 # stash is automatically passed to the view for use in a template
345 $c->forward( 'MyApp::V::TT' );
346
347=cut
348
349sub stash {
350 my $c = shift;
351 if (@_) {
352 my $stash = @_ > 1 ? {@_} : $_[0];
353 while ( my ( $key, $val ) = each %$stash ) {
354 $c->{stash}->{$key} = $val;
355 }
356 }
357 return $c->{stash};
358}
359
b5ecfcf0 360=head2 $c->state
0ef52a96 361
362Contains the return value of the last executed action.
363
0756fe3b 364=cut
365
366# search via regex
367sub _comp_search {
197bd788 368 my ( $c, @names ) = @_;
0756fe3b 369
370 foreach my $name (@names) {
371 foreach my $component ( keys %{ $c->components } ) {
197bd788 372 return $c->components->{$component} if $component =~ /$name/i;
0756fe3b 373 }
374 }
375
376 return undef;
377}
378
379# try explicit component names
380sub _comp_explicit {
197bd788 381 my ( $c, @names ) = @_;
0756fe3b 382
383 foreach my $try (@names) {
197bd788 384 return $c->components->{$try} if ( exists $c->components->{$try} );
0756fe3b 385 }
386
387 return undef;
388}
389
390# like component, but try just these prefixes before regex searching,
391# and do not try to return "sort keys %{ $c->components }"
392sub _comp_prefixes {
197bd788 393 my ( $c, $name, @prefixes ) = @_;
0756fe3b 394
395 my $appclass = ref $c || $c;
396
397 my @names = map { "${appclass}::${_}::${name}" } @prefixes;
398
399 my $comp = $c->_comp_explicit(@names);
400 return $comp if defined($comp);
401 $comp = $c->_comp_search($name);
402 return $comp;
403}
404
3b88a455 405# Find possible names for a prefix
406
407sub _comp_names {
408 my ( $c, @prefixes ) = @_;
409
410 my $appclass = ref $c || $c;
411
412 my @pre = map { "${appclass}::${_}::" } @prefixes;
413
414 my @names;
415
416 COMPONENT: foreach my $comp ($c->component) {
417 foreach my $p (@pre) {
418 if ($comp =~ s/^$p//) {
419 push(@names, $comp);
420 next COMPONENT;
421 }
422 }
423 }
424
425 return @names;
426}
427
649fd1fa 428# Return a component if only one matches.
429sub _comp_singular {
197bd788 430 my ( $c, @prefixes ) = @_;
649fd1fa 431
432 my $appclass = ref $c || $c;
433
197bd788 434 my ( $comp, $rest ) =
435 map { $c->_comp_search("^${appclass}::${_}::") } @prefixes;
649fd1fa 436 return $comp unless $rest;
437}
438
197bd788 439# Filter a component before returning by calling ACCEPT_CONTEXT if available
440sub _filter_component {
441 my ( $c, $comp, @args ) = @_;
442 if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
443 return $comp->ACCEPT_CONTEXT( $c, @args );
444 }
445 else { return $comp }
446}
447
f7b672ef 448=head2 COMPONENT ACCESSORS
0ef52a96 449
b5ecfcf0 450=head2 $c->comp($name)
66e28e3f 451
b5ecfcf0 452=head2 $c->component($name)
fbcc39ad 453
ae1e6b59 454Gets a component object by name. This method is no longer recommended,
455unless you want to get a specific component by full
456class. C<$c-E<gt>controller>, C<$c-E<gt>model>, and C<$c-E<gt>view>
457should be used instead.
fbcc39ad 458
459=cut
460
461sub component {
462 my $c = shift;
463
464 if (@_) {
465
466 my $name = shift;
467
468 my $appclass = ref $c || $c;
469
470 my @names = (
471 $name, "${appclass}::${name}",
e3a13771 472 map { "${appclass}::${_}::${name}" }
473 qw/Model M Controller C View V/
fbcc39ad 474 );
475
0756fe3b 476 my $comp = $c->_comp_explicit(@names);
197bd788 477 return $c->_filter_component( $comp, @_ ) if defined($comp);
fbcc39ad 478
0756fe3b 479 $comp = $c->_comp_search($name);
197bd788 480 return $c->_filter_component( $comp, @_ ) if defined($comp);
fbcc39ad 481 }
482
483 return sort keys %{ $c->components };
484}
485
b5ecfcf0 486=head2 $c->controller($name)
af3ff00e 487
0ef52a96 488Gets a L<Catalyst::Controller> instance by name.
af3ff00e 489
490 $c->controller('Foo')->do_stuff;
491
649fd1fa 492If name is omitted, will return the controller for the dispatched action.
493
af3ff00e 494=cut
495
496sub controller {
197bd788 497 my ( $c, $name, @args ) = @_;
498 return $c->_filter_component( $c->_comp_prefixes( $name, qw/Controller C/ ),
499 @args )
500 if ($name);
501 return $c->component( $c->action->class );
af3ff00e 502}
503
3b88a455 504=head2 $c->controllers
505
506Returns the available names which can be passed to $c->controller
507
508=cut
509
510sub controllers {
511 my ( $c ) = @_;
512 return $c->_comp_names(qw/Controller C/);
513}
514
b5ecfcf0 515=head2 $c->model($name)
fc7ec1d9 516
0ef52a96 517Gets a L<Catalyst::Model> instance by name.
518
519 $c->model('Foo')->do_stuff;
fc7ec1d9 520
649fd1fa 521If the name is omitted, it will look for a config setting 'default_model',
522or check if there is only one model, and forward to it if that's the case.
523
fc7ec1d9 524=cut
525
0ef52a96 526sub model {
197bd788 527 my ( $c, $name, @args ) = @_;
528 return $c->_filter_component( $c->_comp_prefixes( $name, qw/Model M/ ),
529 @args )
530 if $name;
531 return $c->component( $c->config->{default_model} )
532 if $c->config->{default_model};
533 return $c->_filter_component( $c->_comp_singular(qw/Model M/), @args );
649fd1fa 534
0ef52a96 535}
fc7ec1d9 536
3b88a455 537=head2 $c->models
538
539Returns the available names which can be passed to $c->model
540
541=cut
542
543sub models {
544 my ( $c ) = @_;
545 return $c->_comp_names(qw/Model M/);
546}
547
b5ecfcf0 548=head2 $c->view($name)
0ef52a96 549
550Gets a L<Catalyst::View> instance by name.
fc7ec1d9 551
0ef52a96 552 $c->view('Foo')->do_stuff;
fc7ec1d9 553
649fd1fa 554If the name is omitted, it will look for a config setting 'default_view',
555or check if there is only one view, and forward to it if that's the case.
556
fc7ec1d9 557=cut
558
0ef52a96 559sub view {
197bd788 560 my ( $c, $name, @args ) = @_;
561 return $c->_filter_component( $c->_comp_prefixes( $name, qw/View V/ ),
562 @args )
563 if $name;
564 return $c->component( $c->config->{default_view} )
565 if $c->config->{default_view};
566 return $c->_filter_component( $c->_comp_singular(qw/View V/) );
0ef52a96 567}
fbcc39ad 568
3b88a455 569=head2 $c->views
570
571Returns the available names which can be passed to $c->view
572
573=cut
574
575sub views {
576 my ( $c ) = @_;
577 return $c->_comp_names(qw/View V/);
578}
579
0ef52a96 580=head2 Class data and helper classes
fbcc39ad 581
b5ecfcf0 582=head2 $c->config
fbcc39ad 583
0ef52a96 584Returns or takes a hashref containing the application's configuration.
585
61b1d329 586 __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
81557adf 587
a6ad13b6 588You can also use a L<YAML> config file like myapp.yml in your
589applications home directory.
590
591 ---
592 db: dsn:SQLite:foo.db
593
3643e890 594=cut
595
596sub config {
597 my $c = shift;
598
599 $c->log->warn("Setting config after setup has been run is not a good idea.")
600 if ( @_ and $c->setup_finished );
601
602 $c->NEXT::config(@_);
603}
604
b5ecfcf0 605=head2 $c->debug
0ef52a96 606
607Overload to enable debug messages (same as -Debug option).
fbcc39ad 608
609=cut
610
0ef52a96 611sub debug { 0 }
fbcc39ad 612
b5ecfcf0 613=head2 $c->dispatcher
af3ff00e 614
ae1e6b59 615Returns the dispatcher instance. Stringifies to class name. See
616L<Catalyst::Dispatcher>.
af3ff00e 617
b5ecfcf0 618=head2 $c->engine
0ef52a96 619
ae1e6b59 620Returns the engine instance. Stringifies to the class name. See
621L<Catalyst::Engine>.
0ef52a96 622
b5ecfcf0 623=head2 $c->log
0ef52a96 624
9e7673af 625Returns the logging object instance. Unless it is already set, Catalyst sets
626this up with a L<Catalyst::Log> object. To use your own log class, set the
627logger with the C<< __PACKAGE__->log >> method prior to calling
628C<< __PACKAGE__->setup >>.
629
630 __PACKAGE__->log( MyLogger->new );
631 __PACKAGE__->setup;
632
633And later:
0ef52a96 634
ae1e6b59 635 $c->log->info( 'Now logging with my own logger!' );
0ef52a96 636
ae1e6b59 637Your log class should implement the methods described in the
638L<Catalyst::Log> man page.
af3ff00e 639
640=cut
641
f7b672ef 642=head2 UTILITY METHODS
66e28e3f 643
b5ecfcf0 644=head2 $c->path_to(@path)
01033d73 645
ae1e6b59 646Merges C<@path> with C<$c-E<gt>config-E<gt>{home}> and returns a
647L<Path::Class> object.
01033d73 648
649For example:
650
651 $c->path_to( 'db', 'sqlite.db' );
652
653=cut
654
655sub path_to {
656 my ( $c, @path ) = @_;
a738ab68 657 my $path = Path::Class::Dir->new( $c->config->{home}, @path );
01033d73 658 if ( -d $path ) { return $path }
a738ab68 659 else { return Path::Class::File->new( $c->config->{home}, @path ) }
01033d73 660}
661
b5ecfcf0 662=head2 $c->plugin( $name, $class, @args )
0ef52a96 663
ae1e6b59 664Helper method for plugins. It creates a classdata accessor/mutator and
665loads and instantiates the given class.
0ef52a96 666
667 MyApp->plugin( 'prototype', 'HTML::Prototype' );
668
669 $c->prototype->define_javascript_functions;
670
671=cut
672
673sub plugin {
674 my ( $class, $name, $plugin, @args ) = @_;
97b58e17 675 $class->_register_plugin( $plugin, 1 );
0ef52a96 676
677 eval { $plugin->import };
678 $class->mk_classdata($name);
679 my $obj;
680 eval { $obj = $plugin->new(@args) };
681
682 if ($@) {
683 Catalyst::Exception->throw( message =>
684 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
685 }
686
687 $class->$name($obj);
688 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
689 if $class->debug;
690}
691
b5ecfcf0 692=head2 MyApp->setup
fbcc39ad 693
e7f1cf73 694Initializes the dispatcher and engine, loads any plugins, and loads the
ae1e6b59 695model, view, and controller components. You may also specify an array
696of plugins to load here, if you choose to not load them in the C<use
697Catalyst> line.
fbcc39ad 698
0ef52a96 699 MyApp->setup;
700 MyApp->setup( qw/-Debug/ );
fbcc39ad 701
702=cut
703
704sub setup {
0319a12c 705 my ( $class, @arguments ) = @_;
599b5295 706
fbcc39ad 707 unless ( $class->isa('Catalyst') ) {
953b0e15 708
fbcc39ad 709 Catalyst::Exception->throw(
710 message => qq/'$class' does not inherit from Catalyst/ );
1c99e125 711 }
0319a12c 712
fbcc39ad 713 if ( $class->arguments ) {
714 @arguments = ( @arguments, @{ $class->arguments } );
715 }
716
717 # Process options
718 my $flags = {};
719
720 foreach (@arguments) {
721
722 if (/^-Debug$/) {
723 $flags->{log} =
724 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
725 }
726 elsif (/^-(\w+)=?(.*)$/) {
727 $flags->{ lc $1 } = $2;
728 }
729 else {
730 push @{ $flags->{plugins} }, $_;
731 }
732 }
733
99f187d6 734 $class->setup_home( delete $flags->{home} );
735
fbcc39ad 736 $class->setup_log( delete $flags->{log} );
737 $class->setup_plugins( delete $flags->{plugins} );
738 $class->setup_dispatcher( delete $flags->{dispatcher} );
739 $class->setup_engine( delete $flags->{engine} );
fbcc39ad 740
741 for my $flag ( sort keys %{$flags} ) {
742
743 if ( my $code = $class->can( 'setup_' . $flag ) ) {
744 &$code( $class, delete $flags->{$flag} );
745 }
746 else {
747 $class->log->warn(qq/Unknown flag "$flag"/);
748 }
749 }
750
4ff0d824 751 $class->log->warn(
752 <<"EOF") if ( $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::CATALYST_SCRIPT_GEN ) );
753You are running an old script!
754
34a83d89 755 Please update by running (this will overwrite existing files):
756 catalyst.pl -force -scripts $class
757
758 or (this will not overwrite existing files):
759 catalyst.pl -scripts $class
4ff0d824 760EOF
fbcc39ad 761
762 if ( $class->debug ) {
763
764 my @plugins = ();
765
766 {
767 no strict 'refs';
22247e54 768 @plugins =
769 map { $_ . ' ' . ( $_->VERSION || '' ) }
770 grep { /^Catalyst::Plugin/ } @{"$class\::ISA"};
fbcc39ad 771 }
772
773 if (@plugins) {
8c113188 774 my $t = Text::SimpleTable->new(76);
775 $t->row($_) for @plugins;
fbcc39ad 776 $class->log->debug( "Loaded plugins:\n" . $t->draw );
777 }
778
779 my $dispatcher = $class->dispatcher;
780 my $engine = $class->engine;
781 my $home = $class->config->{home};
782
783 $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
784 $class->log->debug(qq/Loaded engine "$engine"/);
785
786 $home
787 ? ( -d $home )
788 ? $class->log->debug(qq/Found home "$home"/)
789 : $class->log->debug(qq/Home "$home" doesn't exist/)
790 : $class->log->debug(q/Couldn't find home/);
791 }
792
793 # Call plugins setup
794 {
795 no warnings qw/redefine/;
796 local *setup = sub { };
797 $class->setup;
798 }
799
800 # Initialize our data structure
801 $class->components( {} );
802
803 $class->setup_components;
804
805 if ( $class->debug ) {
9d3e016e 806 my $t = Text::SimpleTable->new( [ 65, 'Class' ], [ 8, 'Type' ] );
684d10ed 807 for my $comp ( sort keys %{ $class->components } ) {
808 my $type = ref $class->components->{$comp} ? 'instance' : 'class';
809 $t->row( $comp, $type );
810 }
fbcc39ad 811 $class->log->debug( "Loaded components:\n" . $t->draw )
8c113188 812 if ( keys %{ $class->components } );
fbcc39ad 813 }
814
815 # Add our self to components, since we are also a component
816 $class->components->{$class} = $class;
817
818 $class->setup_actions;
819
820 if ( $class->debug ) {
821 my $name = $class->config->{name} || 'Application';
822 $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
823 }
824 $class->log->_flush() if $class->log->can('_flush');
3643e890 825
826 $class->setup_finished(1);
fbcc39ad 827}
828
73664287 829=head2 $c->uri_for( $path, @args?, \%query_values? )
fbcc39ad 830
ae1e6b59 831Merges path with C<$c-E<gt>request-E<gt>base> for absolute uri's and
ccc9f8aa 832with C<$c-E<gt>namespace> for relative uri's, then returns a
ae1e6b59 833normalized L<URI> object. If any args are passed, they are added at the
4f67eddf 834end of the path. If the last argument to uri_for is a hash reference,
835it is assumed to contain GET parameter key/value pairs, which will be
836appended to the URI in standard fashion.
fbcc39ad 837
838=cut
839
840sub uri_for {
00e6a2b7 841 my ( $c, $path, @args ) = @_;
fbcc39ad 842 my $base = $c->request->base->clone;
843 my $basepath = $base->path;
844 $basepath =~ s/\/$//;
fdba7a9d 845 $basepath .= '/';
ccc9f8aa 846 my $namespace = $c->namespace;
00e6a2b7 847
ccc9f8aa 848 # massage namespace, empty if absolute path
849 $namespace =~ s/^\///;
850 $namespace .= '/' if $namespace;
6e0c45c9 851 $path ||= '';
ccc9f8aa 852 $namespace = '' if $path =~ /^\//;
fbcc39ad 853 $path =~ s/^\///;
00e6a2b7 854
97b58e17 855 my $params =
856 ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
8327e2e2 857
5789a3d8 858 for my $value ( values %$params ) {\r
859 my $isa_ref = ref $value;\r
860 if( $isa_ref and $isa_ref ne 'ARRAY' ) {\r
861 croak( "Non-array reference ($isa_ref) passed to uri_for()" );\r
862 }\r
863 utf8::encode( $_ ) for $isa_ref ? @$value : $value;\r
864 };
865
189e2a51 866 # join args with '/', or a blank string
00e6a2b7 867 my $args = ( scalar @args ? '/' . join( '/', @args ) : '' );
d3e7a648 868 $args =~ s/^\/// unless $path;
869 my $res =
870 URI->new_abs( URI->new_abs( "$path$args", "$basepath$namespace" ), $base )
871 ->canonical;
8327e2e2 872 $res->query_form(%$params);
d3e7a648 873 $res;
fbcc39ad 874}
875
b5ecfcf0 876=head2 $c->welcome_message
ab2374d3 877
878Returns the Catalyst welcome HTML page.
879
880=cut
881
882sub welcome_message {
bf1f2c60 883 my $c = shift;
884 my $name = $c->config->{name};
885 my $logo = $c->uri_for('/static/images/catalyst_logo.png');
886 my $prefix = Catalyst::Utils::appprefix( ref $c );
80cdbbff 887 $c->response->content_type('text/html; charset=utf-8');
ab2374d3 888 return <<"EOF";
80cdbbff 889<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
890 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
891<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
ab2374d3 892 <head>
80cdbbff 893 <meta http-equiv="Content-Language" content="en" />
894 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
ab2374d3 895 <title>$name on Catalyst $VERSION</title>
896 <style type="text/css">
897 body {
ab2374d3 898 color: #000;
899 background-color: #eee;
900 }
901 div#content {
902 width: 640px;
80cdbbff 903 margin-left: auto;
904 margin-right: auto;
ab2374d3 905 margin-top: 10px;
906 margin-bottom: 10px;
907 text-align: left;
908 background-color: #ccc;
909 border: 1px solid #aaa;
910 -moz-border-radius: 10px;
911 }
d84c4dab 912 p, h1, h2 {
ab2374d3 913 margin-left: 20px;
914 margin-right: 20px;
16215972 915 font-family: verdana, tahoma, sans-serif;
ab2374d3 916 }
d84c4dab 917 a {
918 font-family: verdana, tahoma, sans-serif;
919 }
d114e033 920 :link, :visited {
921 text-decoration: none;
922 color: #b00;
923 border-bottom: 1px dotted #bbb;
924 }
925 :link:hover, :visited:hover {
d114e033 926 color: #555;
927 }
ab2374d3 928 div#topbar {
929 margin: 0px;
930 }
3e82a295 931 pre {
3e82a295 932 margin: 10px;
933 padding: 8px;
934 }
ab2374d3 935 div#answers {
936 padding: 8px;
937 margin: 10px;
d114e033 938 background-color: #fff;
ab2374d3 939 border: 1px solid #aaa;
940 -moz-border-radius: 10px;
941 }
942 h1 {
33108eaf 943 font-size: 0.9em;
944 font-weight: normal;
ab2374d3 945 text-align: center;
946 }
947 h2 {
948 font-size: 1.0em;
949 }
950 p {
951 font-size: 0.9em;
952 }
ae7c5252 953 p img {
954 float: right;
955 margin-left: 10px;
956 }
9619f23c 957 span#appname {
958 font-weight: bold;
33108eaf 959 font-size: 1.6em;
ab2374d3 960 }
961 </style>
962 </head>
963 <body>
964 <div id="content">
965 <div id="topbar">
9619f23c 966 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
d84c4dab 967 $VERSION</h1>
ab2374d3 968 </div>
969 <div id="answers">
ae7c5252 970 <p>
80cdbbff 971 <img src="$logo" alt="Catalyst Logo" />
ae7c5252 972 </p>
4b8cb778 973 <p>Welcome to the wonderful world of Catalyst.
f92fd545 974 This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
975 framework will make web development something you had
60dd6e1d 976 never expected it to be: Fun, rewarding, and quick.</p>
ab2374d3 977 <h2>What to do now?</h2>
4b8cb778 978 <p>That really depends on what <b>you</b> want to do.
ab2374d3 979 We do, however, provide you with a few starting points.</p>
980 <p>If you want to jump right into web development with Catalyst
5db7f9a1 981 you might want to check out the documentation.</p>
bf1f2c60 982 <pre><code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
1667d231 983perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
bf1f2c60 984perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual.pod">Catalyst::Manual</a></code></pre>
ab2374d3 985 <h2>What to do next?</h2>
f5681c92 986 <p>Next it's time to write an actual application. Use the
80cdbbff 987 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
60dd6e1d 988 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a>, and
989 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>;
bf1f2c60 990 they can save you a lot of work.</p>
991 <pre><code>script/${prefix}_create.pl -help</code></pre>
992 <p>Also, be sure to check out the vast and growing
60dd6e1d 993 collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&amp;mode=all">plugins for Catalyst on CPAN</a>;
bf1f2c60 994 you are likely to find what you need there.
f5681c92 995 </p>
996
82245cc4 997 <h2>Need help?</h2>
f5681c92 998 <p>Catalyst has a very active community. Here are the main places to
999 get in touch with us.</p>
16215972 1000 <ul>
1001 <li>
2b9a7d76 1002 <a href="http://dev.catalyst.perl.org">Wiki</a>
16215972 1003 </li>
1004 <li>
1005 <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
1006 </li>
1007 <li>
4eaf7c88 1008 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
16215972 1009 </li>
1010 </ul>
ab2374d3 1011 <h2>In conclusion</h2>
4e7aa2ea 1012 <p>The Catalyst team hopes you will enjoy using Catalyst as much
f5681c92 1013 as we enjoyed making it. Please contact us if you have ideas
1014 for improvement or other feedback.</p>
ab2374d3 1015 </div>
1016 </div>
1017 </body>
1018</html>
1019EOF
1020}
1021
fbcc39ad 1022=head1 INTERNAL METHODS
1023
ae1e6b59 1024These methods are not meant to be used by end users.
1025
b5ecfcf0 1026=head2 $c->components
fbcc39ad 1027
e7f1cf73 1028Returns a hash of components.
fbcc39ad 1029
b5ecfcf0 1030=head2 $c->context_class
1f9cb7c1 1031
e7f1cf73 1032Returns or sets the context class.
1f9cb7c1 1033
b5ecfcf0 1034=head2 $c->counter
fbcc39ad 1035
ae1e6b59 1036Returns a hashref containing coderefs and execution counts (needed for
1037deep recursion detection).
fbcc39ad 1038
b5ecfcf0 1039=head2 $c->depth
fbcc39ad 1040
e7f1cf73 1041Returns the number of actions on the current internal execution stack.
fbcc39ad 1042
b5ecfcf0 1043=head2 $c->dispatch
fbcc39ad 1044
e7f1cf73 1045Dispatches a request to actions.
fbcc39ad 1046
1047=cut
1048
1049sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
1050
b5ecfcf0 1051=head2 $c->dispatcher_class
1f9cb7c1 1052
e7f1cf73 1053Returns or sets the dispatcher class.
1f9cb7c1 1054
b5ecfcf0 1055=head2 $c->dump_these
7f92deef 1056
ae1e6b59 1057Returns a list of 2-element array references (name, structure) pairs
1058that will be dumped on the error page in debug mode.
7f92deef 1059
1060=cut
1061
1062sub dump_these {
1063 my $c = shift;
1064 [ Request => $c->req ], [ Response => $c->res ], [ Stash => $c->stash ],;
1065}
1066
b5ecfcf0 1067=head2 $c->engine_class
1f9cb7c1 1068
e7f1cf73 1069Returns or sets the engine class.
1f9cb7c1 1070
b5ecfcf0 1071=head2 $c->execute( $class, $coderef )
fbcc39ad 1072
0ef52a96 1073Execute a coderef in given class and catch exceptions. Errors are available
1074via $c->error.
fbcc39ad 1075
1076=cut
1077
1078sub execute {
1079 my ( $c, $class, $code ) = @_;
858828dd 1080 $class = $c->component($class) || $class;
fbcc39ad 1081 $c->state(0);
a0eca838 1082
197bd788 1083 if ( $c->depth >= $RECURSION ) {
1627551a 1084 my $action = "$code";
1085 $action = "/$action" unless $action =~ /\-\>/;
1086 my $error = qq/Deep recursion detected calling "$action"/;
1087 $c->log->error($error);
1088 $c->error($error);
1089 $c->state(0);
1090 return $c->state;
1091 }
1092
7a7d7af5 1093 my $stats_info = $c->_stats_start_execute( $code );
22247e54 1094
8767c5a3 1095 push( @{ $c->stack }, $code );
7a7d7af5 1096
245ae014 1097 eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
22247e54 1098
7a7d7af5 1099 $c->_stats_finish_execute( $stats_info );
1100
f59def82 1101 my $last = ${ $c->stack }[-1];
8767c5a3 1102 pop( @{ $c->stack } );
fbcc39ad 1103
1104 if ( my $error = $@ ) {
28591cd7 1105 if ( $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
fbcc39ad 1106 else {
1107 unless ( ref $error ) {
1108 chomp $error;
f59def82 1109 my $class = $last->class;
1110 my $name = $last->name;
1111 $error = qq/Caught exception in $class->$name "$error"/;
fbcc39ad 1112 }
fbcc39ad 1113 $c->error($error);
1114 $c->state(0);
1115 }
1116 }
1117 return $c->state;
1118}
1119
7a7d7af5 1120sub _stats_start_execute {
1121 my ( $c, $code ) = @_;
1122
1123 return unless $c->debug;
1124
1125 my $action = "$code";
1126
1127 $action = "/$action" unless $action =~ /\-\>/;
1128 $c->counter->{"$code"}++;
1129
1130 # determine if the call was the result of a forward
1131 # this is done by walking up the call stack and looking for a calling
1132 # sub of Catalyst::forward before the eval
1133 my $callsub = q{};
1134 for my $index ( 2 .. 11 ) {
1135 last
1136 if ( ( caller($index) )[0] eq 'Catalyst'
1137 && ( caller($index) )[3] eq '(eval)' );
1138
1139 if ( ( caller($index) )[3] =~ /forward$/ ) {
1140 $callsub = ( caller($index) )[3];
1141 $action = "-> $action";
1142 last;
1143 }
1144 }
1145
1146 my $node = Tree::Simple->new(
1147 {
1148 action => $action,
1149 elapsed => undef, # to be filled in later
1150 comment => "",
1151 }
1152 );
1153 $node->setUID( "$code" . $c->counter->{"$code"} );
1154
1155 unless ( ( $code->name =~ /^_.*/ )
1156 && ( !$c->config->{show_internal_actions} ) )
1157 {
1158 # is this a root-level call or a forwarded call?
1159 if ( $callsub =~ /forward$/ ) {
1160
1161 # forward, locate the caller
1162 if ( my $parent = $c->stack->[-1] ) {
1163 my $visitor = Tree::Simple::Visitor::FindByUID->new;
1164 $visitor->searchForUID(
1165 "$parent" . $c->counter->{"$parent"} );
1166 $c->stats->accept($visitor);
1167 if ( my $result = $visitor->getResult ) {
1168 $result->addChild($node);
1169 }
1170 }
1171 else {
1172
1173 # forward with no caller may come from a plugin
1174 $c->stats->addChild($node);
1175 }
1176 }
1177 else {
1178
1179 # root-level call
1180 $c->stats->addChild($node);
1181 }
1182 }
1183
1184 my $start = [gettimeofday];
1185 my $elapsed = tv_interval($start);
1186
1187 return {
1188 code => $code,
1189 elapsed => $elapsed,
1190 start => $start,
1191 node => $node,
1192 }
1193}
1194
1195sub _stats_finish_execute {
1196 my ( $c, $info ) = @_;
1197
1198 return unless $c->debug;
1199
1200 my ( $code, $start, $elapsed ) = @{ $info }{qw/code start elapsed/};
1201
1202 unless ( ( $code->name =~ /^_.*/ )
1203 && ( !$c->config->{show_internal_actions} ) )
1204 {
1205
1206 # FindByUID uses an internal die, so we save the existing error
1207 my $error = $@;
1208
1209 # locate the node in the tree and update the elapsed time
1210 my $visitor = Tree::Simple::Visitor::FindByUID->new;
1211 $visitor->searchForUID( "$code" . $c->counter->{"$code"} );
1212 $c->stats->accept($visitor);
1213 if ( my $result = $visitor->getResult ) {
1214 my $value = $result->getNodeValue;
1215 $value->{elapsed} = sprintf( '%fs', $elapsed );
1216 $result->setNodeValue($value);
1217 }
1218
1219 # restore error
1220 $@ = $error || undef;
1221 }
1222}
1223
3d0d6d21 1224=head2 $c->_localize_fields( sub { }, \%keys );
1225
1226=cut
1227
1228sub _localize_fields {
1229 my ( $c, $localized, $code ) = ( @_ );
1230
1231 my $request = delete $localized->{request} || {};
1232 my $response = delete $localized->{response} || {};
1233
1234 local @{ $c }{ keys %$localized } = values %$localized;
1235 local @{ $c->request }{ keys %$request } = values %$request;
1236 local @{ $c->response }{ keys %$response } = values %$response;
1237
1238 $code->();
1239}
1240
b5ecfcf0 1241=head2 $c->finalize
fbcc39ad 1242
e7f1cf73 1243Finalizes the request.
fbcc39ad 1244
1245=cut
1246
1247sub finalize {
1248 my $c = shift;
1249
369c09bc 1250 for my $error ( @{ $c->error } ) {
1251 $c->log->error($error);
1252 }
1253
5050d7a7 1254 # Allow engine to handle finalize flow (for POE)
1255 if ( $c->engine->can('finalize') ) {
1256 $c->engine->finalize( $c );
fbcc39ad 1257 }
5050d7a7 1258 else {
fbcc39ad 1259
5050d7a7 1260 $c->finalize_uploads;
fbcc39ad 1261
5050d7a7 1262 # Error
1263 if ( $#{ $c->error } >= 0 ) {
1264 $c->finalize_error;
1265 }
1266
1267 $c->finalize_headers;
fbcc39ad 1268
5050d7a7 1269 # HEAD request
1270 if ( $c->request->method eq 'HEAD' ) {
1271 $c->response->body('');
1272 }
1273
1274 $c->finalize_body;
1275 }
fbcc39ad 1276
1277 return $c->response->status;
1278}
1279
b5ecfcf0 1280=head2 $c->finalize_body
fbcc39ad 1281
e7f1cf73 1282Finalizes body.
fbcc39ad 1283
1284=cut
1285
1286sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1287
b5ecfcf0 1288=head2 $c->finalize_cookies
fbcc39ad 1289
e7f1cf73 1290Finalizes cookies.
fbcc39ad 1291
1292=cut
1293
147821ea 1294sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
fbcc39ad 1295
b5ecfcf0 1296=head2 $c->finalize_error
fbcc39ad 1297
e7f1cf73 1298Finalizes error.
fbcc39ad 1299
1300=cut
1301
1302sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1303
b5ecfcf0 1304=head2 $c->finalize_headers
fbcc39ad 1305
e7f1cf73 1306Finalizes headers.
fbcc39ad 1307
1308=cut
1309
1310sub finalize_headers {
1311 my $c = shift;
1312
1313 # Check if we already finalized headers
1314 return if $c->response->{_finalized_headers};
1315
1316 # Handle redirects
1317 if ( my $location = $c->response->redirect ) {
1318 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1319 $c->response->header( Location => $location );
1320 }
1321
1322 # Content-Length
1323 if ( $c->response->body && !$c->response->content_length ) {
775878ac 1324
8f62c91a 1325 # get the length from a filehandle
197bd788 1326 if ( blessed( $c->response->body ) && $c->response->body->can('read') )
1327 {
8f62c91a 1328 if ( my $stat = stat $c->response->body ) {
1329 $c->response->content_length( $stat->size );
1330 }
1331 else {
775878ac 1332 $c->log->warn('Serving filehandle without a content-length');
8f62c91a 1333 }
1334 }
1335 else {
775878ac 1336 $c->response->content_length( bytes::length( $c->response->body ) );
8f62c91a 1337 }
fbcc39ad 1338 }
1339
1340 # Errors
1341 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
1342 $c->response->headers->remove_header("Content-Length");
1343 $c->response->body('');
1344 }
1345
1346 $c->finalize_cookies;
1347
1348 $c->engine->finalize_headers( $c, @_ );
1349
1350 # Done
1351 $c->response->{_finalized_headers} = 1;
1352}
1353
b5ecfcf0 1354=head2 $c->finalize_output
fbcc39ad 1355
1356An alias for finalize_body.
1357
b5ecfcf0 1358=head2 $c->finalize_read
fbcc39ad 1359
e7f1cf73 1360Finalizes the input after reading is complete.
fbcc39ad 1361
1362=cut
1363
1364sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1365
b5ecfcf0 1366=head2 $c->finalize_uploads
fbcc39ad 1367
ae1e6b59 1368Finalizes uploads. Cleans up any temporary files.
fbcc39ad 1369
1370=cut
1371
1372sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1373
b5ecfcf0 1374=head2 $c->get_action( $action, $namespace )
fbcc39ad 1375
e7f1cf73 1376Gets an action in a given namespace.
fbcc39ad 1377
1378=cut
1379
684d10ed 1380sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
fbcc39ad 1381
b5ecfcf0 1382=head2 $c->get_actions( $action, $namespace )
a9dc674c 1383
ae1e6b59 1384Gets all actions of a given name in a namespace and all parent
1385namespaces.
a9dc674c 1386
1387=cut
1388
1389sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1390
f7b672ef 1391=head2 $c->handle_request( $class, @arguments )
fbcc39ad 1392
e7f1cf73 1393Called to handle each HTTP request.
fbcc39ad 1394
1395=cut
1396
1397sub handle_request {
1398 my ( $class, @arguments ) = @_;
1399
1400 # Always expect worst case!
1401 my $status = -1;
1402 eval {
22247e54 1403 my $stats = ( $class->debug ) ? Tree::Simple->new: q{};
fbcc39ad 1404
1405 my $handler = sub {
1406 my $c = $class->prepare(@arguments);
7a7d7af5 1407 $c->stats($stats);
fbcc39ad 1408 $c->dispatch;
1409 return $c->finalize;
1410 };
1411
1412 if ( $class->debug ) {
245ae014 1413 my $start = [gettimeofday];
1414 $status = &$handler;
1415 my $elapsed = tv_interval $start;
fbcc39ad 1416 $elapsed = sprintf '%f', $elapsed;
1417 my $av = sprintf '%.3f',
1418 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
8c113188 1419 my $t = Text::SimpleTable->new( [ 64, 'Action' ], [ 9, 'Time' ] );
22247e54 1420
1421 $stats->traverse(
1422 sub {
1423 my $action = shift;
1424 my $stat = $action->getNodeValue;
7a7d7af5 1425 $t->row( ( q{ } x $action->getDepth ) . $stat->{action} . $stat->{comment},
22247e54 1426 $stat->{elapsed} || '??' );
1427 }
1428 );
1429
fbcc39ad 1430 $class->log->info(
1431 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
1432 }
1433 else { $status = &$handler }
1434
1435 };
1436
1437 if ( my $error = $@ ) {
1438 chomp $error;
1439 $class->log->error(qq/Caught exception in engine "$error"/);
1440 }
1441
1442 $COUNT++;
1443 $class->log->_flush() if $class->log->can('_flush');
1444 return $status;
1445}
1446
b5ecfcf0 1447=head2 $c->prepare( @arguments )
fbcc39ad 1448
ae1e6b59 1449Creates a Catalyst context from an engine-specific request (Apache, CGI,
1450etc.).
fbcc39ad 1451
1452=cut
1453
1454sub prepare {
1455 my ( $class, @arguments ) = @_;
1456
3cec521a 1457 $class->context_class( ref $class || $class ) unless $class->context_class;
1458 my $c = $class->context_class->new(
1459 {
1460 counter => {},
28591cd7 1461 stack => [],
3cec521a 1462 request => $class->request_class->new(
1463 {
1464 arguments => [],
1465 body_parameters => {},
1466 cookies => {},
1467 headers => HTTP::Headers->new,
1468 parameters => {},
1469 query_parameters => {},
1470 secure => 0,
1471 snippets => [],
1472 uploads => {}
1473 }
1474 ),
1475 response => $class->response_class->new(
1476 {
1477 body => '',
1478 cookies => {},
1479 headers => HTTP::Headers->new(),
1480 status => 200
1481 }
1482 ),
1483 stash => {},
1484 state => 0
1485 }
1486 );
fbcc39ad 1487
1488 # For on-demand data
1489 $c->request->{_context} = $c;
1490 $c->response->{_context} = $c;
1491 weaken( $c->request->{_context} );
1492 weaken( $c->response->{_context} );
1493
1494 if ( $c->debug ) {
1495 my $secs = time - $START || 1;
1496 my $av = sprintf '%.3f', $COUNT / $secs;
1497 $c->log->debug('**********************************');
1498 $c->log->debug("* Request $COUNT ($av/s) [$$]");
1499 $c->log->debug('**********************************');
1500 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1501 }
1502
5050d7a7 1503 # Allow engine to direct the prepare flow (for POE)
1504 if ( $c->engine->can('prepare') ) {
1505 $c->engine->prepare( $c, @arguments );
1506 }
1507 else {
1508 $c->prepare_request(@arguments);
1509 $c->prepare_connection;
1510 $c->prepare_query_parameters;
1511 $c->prepare_headers;
1512 $c->prepare_cookies;
1513 $c->prepare_path;
1514
1515 # On-demand parsing
1516 $c->prepare_body unless $c->config->{parse_on_demand};
1517 }
fbcc39ad 1518
fbcc39ad 1519 my $method = $c->req->method || '';
1520 my $path = $c->req->path || '';
1521 my $address = $c->req->address || '';
1522
e3a13771 1523 $c->log->debug(qq/"$method" request for "$path" from "$address"/)
fbcc39ad 1524 if $c->debug;
1525
e3a13771 1526 $c->prepare_action;
1527
fbcc39ad 1528 return $c;
1529}
1530
b5ecfcf0 1531=head2 $c->prepare_action
fbcc39ad 1532
e7f1cf73 1533Prepares action.
fbcc39ad 1534
1535=cut
1536
1537sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1538
b5ecfcf0 1539=head2 $c->prepare_body
fbcc39ad 1540
e7f1cf73 1541Prepares message body.
fbcc39ad 1542
1543=cut
1544
1545sub prepare_body {
1546 my $c = shift;
1547
1548 # Do we run for the first time?
1549 return if defined $c->request->{_body};
1550
1551 # Initialize on-demand data
1552 $c->engine->prepare_body( $c, @_ );
1553 $c->prepare_parameters;
1554 $c->prepare_uploads;
1555
1556 if ( $c->debug && keys %{ $c->req->body_parameters } ) {
8c113188 1557 my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
fbcc39ad 1558 for my $key ( sort keys %{ $c->req->body_parameters } ) {
1559 my $param = $c->req->body_parameters->{$key};
1560 my $value = defined($param) ? $param : '';
8c113188 1561 $t->row( $key,
fbcc39ad 1562 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1563 }
1564 $c->log->debug( "Body Parameters are:\n" . $t->draw );
1565 }
1566}
1567
b5ecfcf0 1568=head2 $c->prepare_body_chunk( $chunk )
4bd82c41 1569
e7f1cf73 1570Prepares a chunk of data before sending it to L<HTTP::Body>.
4bd82c41 1571
1572=cut
1573
4f5ebacd 1574sub prepare_body_chunk {
1575 my $c = shift;
4bd82c41 1576 $c->engine->prepare_body_chunk( $c, @_ );
1577}
1578
b5ecfcf0 1579=head2 $c->prepare_body_parameters
fbcc39ad 1580
e7f1cf73 1581Prepares body parameters.
fbcc39ad 1582
1583=cut
1584
1585sub prepare_body_parameters {
1586 my $c = shift;
1587 $c->engine->prepare_body_parameters( $c, @_ );
1588}
1589
b5ecfcf0 1590=head2 $c->prepare_connection
fbcc39ad 1591
e7f1cf73 1592Prepares connection.
fbcc39ad 1593
1594=cut
1595
1596sub prepare_connection {
1597 my $c = shift;
1598 $c->engine->prepare_connection( $c, @_ );
1599}
1600
b5ecfcf0 1601=head2 $c->prepare_cookies
fbcc39ad 1602
e7f1cf73 1603Prepares cookies.
fbcc39ad 1604
1605=cut
1606
1607sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1608
b5ecfcf0 1609=head2 $c->prepare_headers
fbcc39ad 1610
e7f1cf73 1611Prepares headers.
fbcc39ad 1612
1613=cut
1614
1615sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1616
b5ecfcf0 1617=head2 $c->prepare_parameters
fbcc39ad 1618
e7f1cf73 1619Prepares parameters.
fbcc39ad 1620
1621=cut
1622
1623sub prepare_parameters {
1624 my $c = shift;
1625 $c->prepare_body_parameters;
1626 $c->engine->prepare_parameters( $c, @_ );
1627}
1628
b5ecfcf0 1629=head2 $c->prepare_path
fbcc39ad 1630
e7f1cf73 1631Prepares path and base.
fbcc39ad 1632
1633=cut
1634
1635sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1636
b5ecfcf0 1637=head2 $c->prepare_query_parameters
fbcc39ad 1638
e7f1cf73 1639Prepares query parameters.
fbcc39ad 1640
1641=cut
1642
1643sub prepare_query_parameters {
1644 my $c = shift;
1645
1646 $c->engine->prepare_query_parameters( $c, @_ );
1647
1648 if ( $c->debug && keys %{ $c->request->query_parameters } ) {
8c113188 1649 my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
fbcc39ad 1650 for my $key ( sort keys %{ $c->req->query_parameters } ) {
1651 my $param = $c->req->query_parameters->{$key};
1652 my $value = defined($param) ? $param : '';
8c113188 1653 $t->row( $key,
fbcc39ad 1654 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1655 }
1656 $c->log->debug( "Query Parameters are:\n" . $t->draw );
1657 }
1658}
1659
b5ecfcf0 1660=head2 $c->prepare_read
fbcc39ad 1661
e7f1cf73 1662Prepares the input for reading.
fbcc39ad 1663
1664=cut
1665
1666sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1667
b5ecfcf0 1668=head2 $c->prepare_request
fbcc39ad 1669
e7f1cf73 1670Prepares the engine request.
fbcc39ad 1671
1672=cut
1673
1674sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1675
b5ecfcf0 1676=head2 $c->prepare_uploads
fbcc39ad 1677
e7f1cf73 1678Prepares uploads.
fbcc39ad 1679
1680=cut
1681
1682sub prepare_uploads {
1683 my $c = shift;
1684
1685 $c->engine->prepare_uploads( $c, @_ );
1686
1687 if ( $c->debug && keys %{ $c->request->uploads } ) {
8c113188 1688 my $t = Text::SimpleTable->new(
1689 [ 12, 'Key' ],
1690 [ 28, 'Filename' ],
1691 [ 18, 'Type' ],
1692 [ 9, 'Size' ]
1693 );
fbcc39ad 1694 for my $key ( sort keys %{ $c->request->uploads } ) {
1695 my $upload = $c->request->uploads->{$key};
1696 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
8c113188 1697 $t->row( $key, $u->filename, $u->type, $u->size );
fbcc39ad 1698 }
1699 }
1700 $c->log->debug( "File Uploads are:\n" . $t->draw );
1701 }
1702}
1703
b5ecfcf0 1704=head2 $c->prepare_write
fbcc39ad 1705
e7f1cf73 1706Prepares the output for writing.
fbcc39ad 1707
1708=cut
1709
1710sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1711
b5ecfcf0 1712=head2 $c->request_class
1f9cb7c1 1713
e7f1cf73 1714Returns or sets the request class.
1f9cb7c1 1715
b5ecfcf0 1716=head2 $c->response_class
1f9cb7c1 1717
e7f1cf73 1718Returns or sets the response class.
1f9cb7c1 1719
b5ecfcf0 1720=head2 $c->read( [$maxlength] )
fbcc39ad 1721
ae1e6b59 1722Reads a chunk of data from the request body. This method is designed to
1723be used in a while loop, reading C<$maxlength> bytes on every call.
1724C<$maxlength> defaults to the size of the request if not specified.
fbcc39ad 1725
ae1e6b59 1726You have to set C<MyApp-E<gt>config-E<gt>{parse_on_demand}> to use this
1727directly.
fbcc39ad 1728
1729=cut
1730
1731sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1732
b5ecfcf0 1733=head2 $c->run
fbcc39ad 1734
1735Starts the engine.
1736
1737=cut
1738
1739sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1740
b5ecfcf0 1741=head2 $c->set_action( $action, $code, $namespace, $attrs )
fbcc39ad 1742
e7f1cf73 1743Sets an action in a given namespace.
fbcc39ad 1744
1745=cut
1746
1747sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1748
b5ecfcf0 1749=head2 $c->setup_actions($component)
fbcc39ad 1750
e7f1cf73 1751Sets up actions for a component.
fbcc39ad 1752
1753=cut
1754
1755sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1756
b5ecfcf0 1757=head2 $c->setup_components
fbcc39ad 1758
e7f1cf73 1759Sets up components.
fbcc39ad 1760
1761=cut
1762
1763sub setup_components {
1764 my $class = shift;
1765
1766 my $callback = sub {
1767 my ( $component, $context ) = @_;
1768
31375184 1769 unless ( $component->can('COMPONENT') ) {
fbcc39ad 1770 return $component;
1771 }
1772
76cb6276 1773 my $suffix = Catalyst::Utils::class2classsuffix($component);
fbcc39ad 1774 my $config = $class->config->{$suffix} || {};
1775
1776 my $instance;
1777
22247e54 1778 eval { $instance = $component->COMPONENT( $context, $config ); };
fbcc39ad 1779
1780 if ( my $error = $@ ) {
1781
1782 chomp $error;
1783
1784 Catalyst::Exception->throw( message =>
1785 qq/Couldn't instantiate component "$component", "$error"/ );
1786 }
1787
1788 Catalyst::Exception->throw( message =>
6c5033cb 1789qq/Couldn't instantiate component "$component", "COMPONENT() didn't return a object"/
fbcc39ad 1790 )
1791 unless ref $instance;
1792 return $instance;
1793 };
1794
6f006bd6 1795 eval "package $class;\n" . q!Module::Pluggable::Fast->import(
fbcc39ad 1796 name => '_catalyst_components',
1797 search => [
1798 "$class\::Controller", "$class\::C",
1799 "$class\::Model", "$class\::M",
1800 "$class\::View", "$class\::V"
1801 ],
1802 callback => $callback
1803 );
4289f674 1804 !;
fbcc39ad 1805
1806 if ( my $error = $@ ) {
1807
1808 chomp $error;
1809
1810 Catalyst::Exception->throw(
1811 message => qq/Couldn't load components "$error"/ );
1812 }
1813
1814 for my $component ( $class->_catalyst_components($class) ) {
1815 $class->components->{ ref $component || $component } = $component;
1816 }
1817}
1818
b5ecfcf0 1819=head2 $c->setup_dispatcher
fbcc39ad 1820
ae1e6b59 1821Sets up dispatcher.
1822
fbcc39ad 1823=cut
1824
1825sub setup_dispatcher {
1826 my ( $class, $dispatcher ) = @_;
1827
1828 if ($dispatcher) {
1829 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1830 }
1831
1832 if ( $ENV{CATALYST_DISPATCHER} ) {
1833 $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1834 }
1835
1836 if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1837 $dispatcher =
1838 'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1839 }
1840
1841 unless ($dispatcher) {
cb0354c6 1842 $dispatcher = $class->dispatcher_class;
fbcc39ad 1843 }
1844
1845 $dispatcher->require;
1846
1847 if ($@) {
1848 Catalyst::Exception->throw(
1849 message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1850 }
1851
1852 # dispatcher instance
1853 $class->dispatcher( $dispatcher->new );
1854}
1855
b5ecfcf0 1856=head2 $c->setup_engine
fbcc39ad 1857
ae1e6b59 1858Sets up engine.
1859
fbcc39ad 1860=cut
1861
1862sub setup_engine {
1863 my ( $class, $engine ) = @_;
1864
1865 if ($engine) {
1866 $engine = 'Catalyst::Engine::' . $engine;
1867 }
1868
1869 if ( $ENV{CATALYST_ENGINE} ) {
1870 $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1871 }
1872
1873 if ( $ENV{ uc($class) . '_ENGINE' } ) {
1874 $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1875 }
1876
9b0a3e0f 1877 if ( $ENV{MOD_PERL} ) {
fbcc39ad 1878
1879 # create the apache method
1880 {
1881 no strict 'refs';
1882 *{"$class\::apache"} = sub { shift->engine->apache };
1883 }
1884
1885 my ( $software, $version ) =
1886 $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1887
1888 $version =~ s/_//g;
1889 $version =~ s/(\.[^.]+)\./$1/g;
1890
1891 if ( $software eq 'mod_perl' ) {
1892
9b0a3e0f 1893 if ( !$engine ) {
22247e54 1894
9b0a3e0f 1895 if ( $version >= 1.99922 ) {
1896 $engine = 'Catalyst::Engine::Apache2::MP20';
1897 }
22247e54 1898
9b0a3e0f 1899 elsif ( $version >= 1.9901 ) {
1900 $engine = 'Catalyst::Engine::Apache2::MP19';
1901 }
22247e54 1902
9b0a3e0f 1903 elsif ( $version >= 1.24 ) {
1904 $engine = 'Catalyst::Engine::Apache::MP13';
1905 }
22247e54 1906
9b0a3e0f 1907 else {
1908 Catalyst::Exception->throw( message =>
1909 qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1910 }
fbcc39ad 1911
fbcc39ad 1912 }
1913
1914 # install the correct mod_perl handler
1915 if ( $version >= 1.9901 ) {
1916 *handler = sub : method {
1917 shift->handle_request(@_);
1918 };
1919 }
1920 else {
1921 *handler = sub ($$) { shift->handle_request(@_) };
1922 }
1923
1924 }
1925
1926 elsif ( $software eq 'Zeus-Perl' ) {
1927 $engine = 'Catalyst::Engine::Zeus';
1928 }
1929
1930 else {
1931 Catalyst::Exception->throw(
1932 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1933 }
1934 }
1935
1936 unless ($engine) {
cb0354c6 1937 $engine = $class->engine_class;
fbcc39ad 1938 }
1939
1940 $engine->require;
1941
1942 if ($@) {
1943 Catalyst::Exception->throw( message =>
1944qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1945 );
1946 }
0e7f5826 1947
d54484bf 1948 # check for old engines that are no longer compatible
1949 my $old_engine;
0e7f5826 1950 if ( $engine->isa('Catalyst::Engine::Apache')
1951 && !Catalyst::Engine::Apache->VERSION )
d54484bf 1952 {
1953 $old_engine = 1;
1954 }
0e7f5826 1955
d54484bf 1956 elsif ( $engine->isa('Catalyst::Engine::Server::Base')
0e7f5826 1957 && Catalyst::Engine::Server->VERSION le '0.02' )
d54484bf 1958 {
1959 $old_engine = 1;
1960 }
0e7f5826 1961
1962 elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
1963 && $engine->VERSION eq '0.01' )
d54484bf 1964 {
1965 $old_engine = 1;
1966 }
0e7f5826 1967
1968 elsif ($engine->isa('Catalyst::Engine::Zeus')
1969 && $engine->VERSION eq '0.01' )
d54484bf 1970 {
1971 $old_engine = 1;
1972 }
fbcc39ad 1973
d54484bf 1974 if ($old_engine) {
1975 Catalyst::Exception->throw( message =>
0e7f5826 1976 qq/Engine "$engine" is not supported by this version of Catalyst/
d54484bf 1977 );
1978 }
0e7f5826 1979
fbcc39ad 1980 # engine instance
1981 $class->engine( $engine->new );
1982}
1983
b5ecfcf0 1984=head2 $c->setup_home
fbcc39ad 1985
ae1e6b59 1986Sets up the home directory.
1987
fbcc39ad 1988=cut
1989
1990sub setup_home {
1991 my ( $class, $home ) = @_;
1992
1993 if ( $ENV{CATALYST_HOME} ) {
1994 $home = $ENV{CATALYST_HOME};
1995 }
1996
1997 if ( $ENV{ uc($class) . '_HOME' } ) {
1998 $home = $ENV{ uc($class) . '_HOME' };
1999 }
2000
2001 unless ($home) {
2002 $home = Catalyst::Utils::home($class);
2003 }
2004
2005 if ($home) {
2006 $class->config->{home} ||= $home;
a738ab68 2007 $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
fbcc39ad 2008 }
2009}
2010
b5ecfcf0 2011=head2 $c->setup_log
fbcc39ad 2012
ae1e6b59 2013Sets up log.
2014
fbcc39ad 2015=cut
2016
2017sub setup_log {
2018 my ( $class, $debug ) = @_;
2019
2020 unless ( $class->log ) {
2021 $class->log( Catalyst::Log->new );
2022 }
af3ff00e 2023
71f074a9 2024 my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
71f074a9 2025
af3ff00e 2026 if (
2027 ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
2028 ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
2029 : $debug
2030 )
2031 {
fbcc39ad 2032 no strict 'refs';
2033 *{"$class\::debug"} = sub { 1 };
2034 $class->log->debug('Debug messages enabled');
2035 }
2036}
2037
b5ecfcf0 2038=head2 $c->setup_plugins
fbcc39ad 2039
ae1e6b59 2040Sets up plugins.
2041
fbcc39ad 2042=cut
2043
836e1134 2044=head2 $c->registered_plugins
2045
2046Returns a sorted list of the plugins which have either been stated in the
2047import list or which have been added via C<< MyApp->plugin(@args); >>.
2048
2049If passed a given plugin name, it will report a boolean value indicating
2050whether or not that plugin is loaded. A fully qualified name is required if
2051the plugin name does not begin with C<Catalyst::Plugin::>.
2052
2053 if ($c->registered_plugins('Some::Plugin')) {
2054 ...
2055 }
2056
2057=cut
fbcc39ad 2058
836e1134 2059{
97b58e17 2060
2061 sub registered_plugins {
836e1134 2062 my $proto = shift;
197bd788 2063 return sort keys %{ $proto->_plugins } unless @_;
836e1134 2064 my $plugin = shift;
d0d4d785 2065 return 1 if exists $proto->_plugins->{$plugin};
2066 return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
836e1134 2067 }
fbcc39ad 2068
836e1134 2069 sub _register_plugin {
2070 my ( $proto, $plugin, $instant ) = @_;
2071 my $class = ref $proto || $proto;
fbcc39ad 2072
2073 $plugin->require;
2074
836e1134 2075 if ( my $error = $@ ) {
2076 my $type = $instant ? "instant " : '';
fbcc39ad 2077 Catalyst::Exception->throw(
836e1134 2078 message => qq/Couldn't load ${type}plugin "$plugin", $error/ );
fbcc39ad 2079 }
2080
197bd788 2081 $proto->_plugins->{$plugin} = 1;
836e1134 2082 unless ($instant) {
fbcc39ad 2083 no strict 'refs';
2084 unshift @{"$class\::ISA"}, $plugin;
2085 }
836e1134 2086 return $class;
2087 }
2088
2089 sub setup_plugins {
2090 my ( $class, $plugins ) = @_;
2091
d0d4d785 2092 $class->_plugins( {} ) unless $class->_plugins;
836e1134 2093 $plugins ||= [];
2094 for my $plugin ( reverse @$plugins ) {
2095
2096 unless ( $plugin =~ s/\A\+// ) {
2097 $plugin = "Catalyst::Plugin::$plugin";
2098 }
2099
2100 $class->_register_plugin($plugin);
2101 }
fbcc39ad 2102 }
2103}
2104
b5ecfcf0 2105=head2 $c->stack
8767c5a3 2106
f7b672ef 2107Returns an arrayref of the internal execution stack (actions that are currently
2108executing).
8767c5a3 2109
b5ecfcf0 2110=head2 $c->write( $data )
fbcc39ad 2111
ae1e6b59 2112Writes $data to the output stream. When using this method directly, you
2113will need to manually set the C<Content-Length> header to the length of
2114your output data, if known.
fbcc39ad 2115
2116=cut
2117
4f5ebacd 2118sub write {
2119 my $c = shift;
2120
2121 # Finalize headers if someone manually writes output
2122 $c->finalize_headers;
2123
2124 return $c->engine->write( $c, @_ );
2125}
fbcc39ad 2126
b5ecfcf0 2127=head2 version
bf88a181 2128
ae1e6b59 2129Returns the Catalyst version number. Mostly useful for "powered by"
2130messages in template systems.
bf88a181 2131
2132=cut
2133
2134sub version { return $Catalyst::VERSION }
2135
b0bb11ec 2136=head1 INTERNAL ACTIONS
2137
ae1e6b59 2138Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
2139C<_ACTION>, and C<_END>. These are by default not shown in the private
3e705254 2140action table, but you can make them visible with a config parameter.
b0bb11ec 2141
2142 MyApp->config->{show_internal_actions} = 1;
2143
d2ee9760 2144=head1 CASE SENSITIVITY
2145
3e705254 2146By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
ae1e6b59 2147mapped to C</foo/bar>. You can activate case sensitivity with a config
3e705254 2148parameter.
d2ee9760 2149
2150 MyApp->config->{case_sensitive} = 1;
2151
3e705254 2152This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
fbcc39ad 2153
2154=head1 ON-DEMAND PARSER
2155
2156The request body is usually parsed at the beginning of a request,
3e705254 2157but if you want to handle input yourself or speed things up a bit,
fbcc39ad 2158you can enable on-demand parsing with a config parameter.
2159
2160 MyApp->config->{parse_on_demand} = 1;
2161
2162=head1 PROXY SUPPORT
2163
ae1e6b59 2164Many production servers operate using the common double-server approach,
2165with a lightweight frontend web server passing requests to a larger
2166backend server. An application running on the backend server must deal
2167with two problems: the remote user always appears to be C<127.0.0.1> and
2168the server's hostname will appear to be C<localhost> regardless of the
2169virtual host that the user connected through.
fbcc39ad 2170
ae1e6b59 2171Catalyst will automatically detect this situation when you are running
2172the frontend and backend servers on the same machine. The following
2173changes are made to the request.
fbcc39ad 2174
ae1e6b59 2175 $c->req->address is set to the user's real IP address, as read from
2176 the HTTP X-Forwarded-For header.
fbcc39ad 2177
ae1e6b59 2178 The host value for $c->req->base and $c->req->uri is set to the real
2179 host, as read from the HTTP X-Forwarded-Host header.
fbcc39ad 2180
3e705254 2181Obviously, your web server must support these headers for this to work.
fbcc39ad 2182
ae1e6b59 2183In a more complex server farm environment where you may have your
2184frontend proxy server(s) on different machines, you will need to set a
2185configuration option to tell Catalyst to read the proxied data from the
2186headers.
fbcc39ad 2187
2188 MyApp->config->{using_frontend_proxy} = 1;
2189
2190If you do not wish to use the proxy support at all, you may set:
d1a31ac6 2191
fbcc39ad 2192 MyApp->config->{ignore_frontend_proxy} = 1;
2193
2194=head1 THREAD SAFETY
2195
2196Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
3e705254 2197and the standalone forking HTTP server on Windows. We believe the Catalyst
fbcc39ad 2198core to be thread-safe.
2199
2200If you plan to operate in a threaded environment, remember that all other
3e705254 2201modules you are using must also be thread-safe. Some modules, most notably
2202L<DBD::SQLite>, are not thread-safe.
d1a31ac6 2203
3cb1db8c 2204=head1 SUPPORT
2205
2206IRC:
2207
4eaf7c88 2208 Join #catalyst on irc.perl.org.
3cb1db8c 2209
3e705254 2210Mailing Lists:
3cb1db8c 2211
2212 http://lists.rawmode.org/mailman/listinfo/catalyst
2213 http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1985c30b 2214
432d507d 2215Web:
2216
2217 http://catalyst.perl.org
2218
0ef52a96 2219Wiki:
2220
2221 http://dev.catalyst.perl.org
2222
fc7ec1d9 2223=head1 SEE ALSO
2224
829a28ca 2225=head2 L<Task::Catalyst> - All you need to start with Catalyst
2226
b5ecfcf0 2227=head2 L<Catalyst::Manual> - The Catalyst Manual
e7f1cf73 2228
b5ecfcf0 2229=head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
61b1e958 2230
b5ecfcf0 2231=head2 L<Catalyst::Engine> - Core engine
61b1e958 2232
b5ecfcf0 2233=head2 L<Catalyst::Log> - Log class.
61b1e958 2234
b5ecfcf0 2235=head2 L<Catalyst::Request> - Request object
61b1e958 2236
b5ecfcf0 2237=head2 L<Catalyst::Response> - Response object
61b1e958 2238
b5ecfcf0 2239=head2 L<Catalyst::Test> - The test suite.
fc7ec1d9 2240
15f0b5b7 2241=head1 CREDITS
fc7ec1d9 2242
15f0b5b7 2243Andy Grundman
2244
fbcc39ad 2245Andy Wardley
2246
33108eaf 2247Andreas Marienborg
2248
f4a57de4 2249Andrew Bramble
2250
15f0b5b7 2251Andrew Ford
2252
2253Andrew Ruthven
2254
fbcc39ad 2255Arthur Bergman
2256
15f0b5b7 2257Autrijus Tang
2258
0cf56dbc 2259Brian Cassidy
2260
6aaa1c60 2261Carl Franks
2262
15f0b5b7 2263Christian Hansen
2264
2265Christopher Hicks
2266
2267Dan Sully
2268
2269Danijel Milicevic
2270
0ef52a96 2271David Kamholz
2272
15f0b5b7 2273David Naughton
2274
61bef238 2275Drew Taylor
2276
15f0b5b7 2277Gary Ashton Jones
2278
2279Geoff Richards
2280
2281Jesse Sheidlower
2282
fbcc39ad 2283Jesse Vincent
2284
15f0b5b7 2285Jody Belka
2286
2287Johan Lindstrom
2288
2289Juan Camacho
2290
2291Leon Brocard
2292
2293Marcus Ramberg
2294
2295Matt S Trout
2296
71c3bcc3 2297Robert Sedlacek
2298
a727119f 2299Sam Vilain
2300
1cf1c56a 2301Sascha Kiefer
2302
15f0b5b7 2303Tatsuhiko Miyagawa
fc7ec1d9 2304
51f0308d 2305Ulf Edvinsson
2306
bdcb95ef 2307Yuval Kogman
2308
51f0308d 2309=head1 AUTHOR
2310
2311Sebastian Riedel, C<sri@oook.de>
2312
fc7ec1d9 2313=head1 LICENSE
2314
9ce5ab63 2315This library is free software, you can redistribute it and/or modify it under
41ca9ba7 2316the same terms as Perl itself.
fc7ec1d9 2317
2318=cut
2319
23201;