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