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