lib/Catalyst.pm

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