lib/Catalyst.pm

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