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