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