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