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