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