lib/Catalyst.pm

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