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