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