lib/Catalyst.pm

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