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