lib/Catalyst.pm

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