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             my $comp = $c->components->{$component} if $component =~ /$name/i;
 370             if ($comp) {
 371                 if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
 372                     return $comp->ACCEPT_CONTEXT($c);
 373                 }
 374                 else { return $comp }
 375             }
 376         }
 377     }
 378
 379     return undef;
 380 }
 381
 382 # try explicit component names
 383 sub _comp_explicit {
 384     my ($c, @names) = @_;
 385
 386     foreach my $try (@names) {
 387         if ( exists $c->components->{$try} ) {
 388             my $comp = $c->components->{$try};
 389             if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
 390                 return $comp->ACCEPT_CONTEXT($c);
 391             }
 392             else { return $comp }
 393         }
 394     }
 395
 396     return undef;
 397 }
 398
 399 # like component, but try just these prefixes before regex searching,
 400 #  and do not try to return "sort keys %{ $c->components }"
 401 sub _comp_prefixes {
 402     my ($c, $name, @prefixes) = @_;
 403
 404     my $appclass = ref $c || $c;
 405
 406     my @names = map { "${appclass}::${_}::${name}" } @prefixes;
 407
 408     my $comp = $c->_comp_explicit(@names);
 409     return $comp if defined($comp);
 410     $comp = $c->_comp_search($name);
 411     return $comp;
 412 }
 413
 414 # Return a component if only one matches.
 415 sub _comp_singular {
 416     my ($c, @prefixes) = @_;
 417
 418     my $appclass = ref $c || $c;
 419
 420     my ($comp,$rest) = map { $c->_comp_search("^${appclass}::${_}::") }
 421         @prefixes;
 422     return $comp unless $rest;
 423 }
 424
 425 =head2 COMPONENT ACCESSORS
 426
 427 =head2 $c->comp($name)
 428
 429 =head2 $c->component($name)
 430
 431 Gets a component object by name. This method is no longer recommended,
 432 unless you want to get a specific component by full
 433 class. C<$c-E<gt>controller>, C<$c-E<gt>model>, and C<$c-E<gt>view>
 434 should be used instead.
 435
 436 =cut
 437
 438 sub component {
 439     my $c = shift;
 440
 441     if (@_) {
 442
 443         my $name = shift;
 444
 445         my $appclass = ref $c || $c;
 446
 447         my @names = (
 448             $name, "${appclass}::${name}",
 449             map { "${appclass}::${_}::${name}" }
 450               qw/Model M Controller C View V/
 451         );
 452
 453         my $comp = $c->_comp_explicit(@names);
 454         return $comp if defined($comp);
 455
 456         $comp = $c->_comp_search($name);
 457         return $comp if defined($comp);
 458     }
 459
 460     return sort keys %{ $c->components };
 461 }
 462
 463 =head2 $c->controller($name)
 464
 465 Gets a L<Catalyst::Controller> instance by name.
 466
 467     $c->controller('Foo')->do_stuff;
 468
 469 If name is omitted, will return the controller for the dispatched action.
 470
 471 =cut
 472
 473 sub controller {
 474     my ( $c, $name ) = @_;
 475     return $c->_comp_prefixes($name, qw/Controller C/)
 476         if ($name);
 477     return $c->component($c->action->class);
 478 }
 479
 480 =head2 $c->model($name)
 481
 482 Gets a L<Catalyst::Model> instance by name.
 483
 484     $c->model('Foo')->do_stuff;
 485
 486 If the name is omitted, it will look for a config setting 'default_model',
 487 or check if there is only one model, and forward to it if that's the case.
 488
 489 =cut
 490
 491 sub model {
 492     my ( $c, $name ) = @_;
 493     return $c->_comp_prefixes($name, qw/Model M/)
 494         if $name;
 495     return $c->comp($c->config->{default_model})
 496         if $c->config->{default_model};
 497     return $c->_comp_singular(qw/Model M/);
 498
 499 }
 500
 501 =head2 $c->view($name)
 502
 503 Gets a L<Catalyst::View> instance by name.
 504
 505     $c->view('Foo')->do_stuff;
 506
 507 If the name is omitted, it will look for a config setting 'default_view',
 508 or check if there is only one view, and forward to it if that's the case.
 509
 510 =cut
 511
 512 sub view {
 513     my ( $c, $name ) = @_;
 514     return $c->_comp_prefixes($name, qw/View V/)
 515         if $name;
 516     return $c->comp($c->config->{default_view})
 517         if $c->config->{default_view};
 518     return $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
1027     if ( $c->debug ) {
1028         my $action = "$code";
1029         $action = "/$action" unless $action =~ /\-\>/;
1030         $c->counter->{"$code"}++;
1031
1032         # determine if the call was the result of a forward
1033         # this is done by walking up the call stack and looking for a calling
1034         # sub of Catalyst::forward before the eval
1035         my $callsub = q{};
1036         for my $index ( 1 .. 10 ) {
1037             last
1038               if ( ( caller($index) )[0] eq 'Catalyst'
1039                 && ( caller($index) )[3] eq '(eval)' );
1040
1041             if ( ( caller($index) )[3] =~ /forward$/ ) {
1042                 $callsub = ( caller($index) )[3];
1043                 $action  = "-> $action";
1044                 last;
1045             }
1046         }
1047
1048         my $node = Tree::Simple->new(
1049             {
1050                 action  => $action,
1051                 elapsed => undef,     # to be filled in later
1052             }
1053         );
1054         $node->setUID( "$code" . $c->counter->{"$code"} );
1055
1056         unless ( ( $code->name =~ /^_.*/ )
1057             && ( !$c->config->{show_internal_actions} ) )
1058         {
1059
1060             # is this a root-level call or a forwarded call?
1061             if ( $callsub =~ /forward$/ ) {
1062
1063                 # forward, locate the caller
1064                 if ( my $parent = $c->stack->[-1] ) {
1065                     my $visitor = Tree::Simple::Visitor::FindByUID->new;
1066                     $visitor->searchForUID(
1067                         "$parent" . $c->counter->{"$parent"} );
1068                     $c->{stats}->accept($visitor);
1069                     if ( my $result = $visitor->getResult ) {
1070                         $result->addChild($node);
1071                     }
1072                 }
1073                 else {
1074
1075                     # forward with no caller may come from a plugin
1076                     $c->{stats}->addChild($node);
1077                 }
1078             }
1079             else {
1080
1081                 # root-level call
1082                 $c->{stats}->addChild($node);
1083             }
1084         }
1085     }
1086
1087     push( @{ $c->stack }, $code );
1088     my $elapsed = 0;
1089     my $start   = 0;
1090     $start = [gettimeofday] if $c->debug;
1091     eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
1092     $elapsed = tv_interval($start) if $c->debug;
1093
1094     if ( $c->debug ) {
1095         unless ( ( $code->name =~ /^_.*/ )
1096             && ( !$c->config->{show_internal_actions} ) )
1097         {
1098
1099             # FindByUID uses an internal die, so we save the existing error
1100             my $error = $@;
1101
1102             # locate the node in the tree and update the elapsed time
1103             my $visitor = Tree::Simple::Visitor::FindByUID->new;
1104             $visitor->searchForUID( "$code" . $c->counter->{"$code"} );
1105             $c->{stats}->accept($visitor);
1106             if ( my $result = $visitor->getResult ) {
1107                 my $value = $result->getNodeValue;
1108                 $value->{elapsed} = sprintf( '%fs', $elapsed );
1109                 $result->setNodeValue($value);
1110             }
1111
1112             # restore error
1113             $@ = $error || undef;
1114         }
1115     }
1116     my $last = ${ $c->stack }[-1];
1117     pop( @{ $c->stack } );
1118
1119     if ( my $error = $@ ) {
1120         if ( $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
1121         else {
1122             unless ( ref $error ) {
1123                 chomp $error;
1124                 my $class = $last->class;
1125                 my $name  = $last->name;
1126                 $error = qq/Caught exception in $class->$name "$error"/;
1127             }
1128             $c->error($error);
1129             $c->state(0);
1130         }
1131     }
1132     return $c->state;
1133 }
1134
1135 =head2 $c->finalize
1136
1137 Finalizes the request.
1138
1139 =cut
1140
1141 sub finalize {
1142     my $c = shift;
1143
1144     for my $error ( @{ $c->error } ) {
1145         $c->log->error($error);
1146     }
1147
1148     $c->finalize_uploads;
1149
1150     # Error
1151     if ( $#{ $c->error } >= 0 ) {
1152         $c->finalize_error;
1153     }
1154
1155     $c->finalize_headers;
1156
1157     # HEAD request
1158     if ( $c->request->method eq 'HEAD' ) {
1159         $c->response->body('');
1160     }
1161
1162     $c->finalize_body;
1163
1164     return $c->response->status;
1165 }
1166
1167 =head2 $c->finalize_body
1168
1169 Finalizes body.
1170
1171 =cut
1172
1173 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1174
1175 =head2 $c->finalize_cookies
1176
1177 Finalizes cookies.
1178
1179 =cut
1180
1181 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
1182
1183 =head2 $c->finalize_error
1184
1185 Finalizes error.
1186
1187 =cut
1188
1189 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1190
1191 =head2 $c->finalize_headers
1192
1193 Finalizes headers.
1194
1195 =cut
1196
1197 sub finalize_headers {
1198     my $c = shift;
1199
1200     # Check if we already finalized headers
1201     return if $c->response->{_finalized_headers};
1202
1203     # Handle redirects
1204     if ( my $location = $c->response->redirect ) {
1205         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1206         $c->response->header( Location => $location );
1207     }
1208
1209     # Content-Length
1210     if ( $c->response->body && !$c->response->content_length ) {
1211
1212         # get the length from a filehandle
1213         if ( blessed($c->response->body) && $c->response->body->can('read') ) {
1214             if ( my $stat = stat $c->response->body ) {
1215                 $c->response->content_length( $stat->size );
1216             }
1217             else {
1218                 $c->log->warn('Serving filehandle without a content-length');
1219             }
1220         }
1221         else {
1222             $c->response->content_length( bytes::length( $c->response->body ) );
1223         }
1224     }
1225
1226     # Errors
1227     if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
1228         $c->response->headers->remove_header("Content-Length");
1229         $c->response->body('');
1230     }
1231
1232     $c->finalize_cookies;
1233
1234     $c->engine->finalize_headers( $c, @_ );
1235
1236     # Done
1237     $c->response->{_finalized_headers} = 1;
1238 }
1239
1240 =head2 $c->finalize_output
1241
1242 An alias for finalize_body.
1243
1244 =head2 $c->finalize_read
1245
1246 Finalizes the input after reading is complete.
1247
1248 =cut
1249
1250 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1251
1252 =head2 $c->finalize_uploads
1253
1254 Finalizes uploads. Cleans up any temporary files.
1255
1256 =cut
1257
1258 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1259
1260 =head2 $c->get_action( $action, $namespace )
1261
1262 Gets an action in a given namespace.
1263
1264 =cut
1265
1266 sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
1267
1268 =head2 $c->get_actions( $action, $namespace )
1269
1270 Gets all actions of a given name in a namespace and all parent
1271 namespaces.
1272
1273 =cut
1274
1275 sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1276
1277 =head2 $c->handle_request( $class, @arguments )
1278
1279 Called to handle each HTTP request.
1280
1281 =cut
1282
1283 sub handle_request {
1284     my ( $class, @arguments ) = @_;
1285
1286     # Always expect worst case!
1287     my $status = -1;
1288     eval {
1289         my $stats = ( $class->debug ) ? Tree::Simple->new: q{};
1290
1291         my $handler = sub {
1292             my $c = $class->prepare(@arguments);
1293             $c->{stats} = $stats;
1294             $c->dispatch;
1295             return $c->finalize;
1296         };
1297
1298         if ( $class->debug ) {
1299             my $start = [gettimeofday];
1300             $status = &$handler;
1301             my $elapsed = tv_interval $start;
1302             $elapsed = sprintf '%f', $elapsed;
1303             my $av = sprintf '%.3f',
1304               ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
1305             my $t = Text::SimpleTable->new( [ 64, 'Action' ], [ 9, 'Time' ] );
1306
1307             $stats->traverse(
1308                 sub {
1309                     my $action = shift;
1310                     my $stat   = $action->getNodeValue;
1311                     $t->row( ( q{ } x $action->getDepth ) . $stat->{action},
1312                         $stat->{elapsed} || '??' );
1313                 }
1314             );
1315
1316             $class->log->info(
1317                 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
1318         }
1319         else { $status = &$handler }
1320
1321     };
1322
1323     if ( my $error = $@ ) {
1324         chomp $error;
1325         $class->log->error(qq/Caught exception in engine "$error"/);
1326     }
1327
1328     $COUNT++;
1329     $class->log->_flush() if $class->log->can('_flush');
1330     return $status;
1331 }
1332
1333 =head2 $c->prepare( @arguments )
1334
1335 Creates a Catalyst context from an engine-specific request (Apache, CGI,
1336 etc.).
1337
1338 =cut
1339
1340 sub prepare {
1341     my ( $class, @arguments ) = @_;
1342
1343     $class->context_class( ref $class || $class ) unless $class->context_class;
1344     my $c = $class->context_class->new(
1345         {
1346             counter => {},
1347             stack   => [],
1348             request => $class->request_class->new(
1349                 {
1350                     arguments        => [],
1351                     body_parameters  => {},
1352                     cookies          => {},
1353                     headers          => HTTP::Headers->new,
1354                     parameters       => {},
1355                     query_parameters => {},
1356                     secure           => 0,
1357                     snippets         => [],
1358                     uploads          => {}
1359                 }
1360             ),
1361             response => $class->response_class->new(
1362                 {
1363                     body    => '',
1364                     cookies => {},
1365                     headers => HTTP::Headers->new(),
1366                     status  => 200
1367                 }
1368             ),
1369             stash => {},
1370             state => 0
1371         }
1372     );
1373
1374     # For on-demand data
1375     $c->request->{_context}  = $c;
1376     $c->response->{_context} = $c;
1377     weaken( $c->request->{_context} );
1378     weaken( $c->response->{_context} );
1379
1380     if ( $c->debug ) {
1381         my $secs = time - $START || 1;
1382         my $av = sprintf '%.3f', $COUNT / $secs;
1383         $c->log->debug('**********************************');
1384         $c->log->debug("* Request $COUNT ($av/s) [$$]");
1385         $c->log->debug('**********************************');
1386         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1387     }
1388
1389     $c->prepare_request(@arguments);
1390     $c->prepare_connection;
1391     $c->prepare_query_parameters;
1392     $c->prepare_headers;
1393     $c->prepare_cookies;
1394     $c->prepare_path;
1395
1396     # On-demand parsing
1397     $c->prepare_body unless $c->config->{parse_on_demand};
1398
1399     my $method  = $c->req->method  || '';
1400     my $path    = $c->req->path    || '';
1401     my $address = $c->req->address || '';
1402
1403     $c->log->debug(qq/"$method" request for "$path" from "$address"/)
1404       if $c->debug;
1405
1406     $c->prepare_action;
1407
1408     return $c;
1409 }
1410
1411 =head2 $c->prepare_action
1412
1413 Prepares action.
1414
1415 =cut
1416
1417 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1418
1419 =head2 $c->prepare_body
1420
1421 Prepares message body.
1422
1423 =cut
1424
1425 sub prepare_body {
1426     my $c = shift;
1427
1428     # Do we run for the first time?
1429     return if defined $c->request->{_body};
1430
1431     # Initialize on-demand data
1432     $c->engine->prepare_body( $c, @_ );
1433     $c->prepare_parameters;
1434     $c->prepare_uploads;
1435
1436     if ( $c->debug && keys %{ $c->req->body_parameters } ) {
1437         my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1438         for my $key ( sort keys %{ $c->req->body_parameters } ) {
1439             my $param = $c->req->body_parameters->{$key};
1440             my $value = defined($param) ? $param : '';
1441             $t->row( $key,
1442                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1443         }
1444         $c->log->debug( "Body Parameters are:\n" . $t->draw );
1445     }
1446 }
1447
1448 =head2 $c->prepare_body_chunk( $chunk )
1449
1450 Prepares a chunk of data before sending it to L<HTTP::Body>.
1451
1452 =cut
1453
1454 sub prepare_body_chunk {
1455     my $c = shift;
1456     $c->engine->prepare_body_chunk( $c, @_ );
1457 }
1458
1459 =head2 $c->prepare_body_parameters
1460
1461 Prepares body parameters.
1462
1463 =cut
1464
1465 sub prepare_body_parameters {
1466     my $c = shift;
1467     $c->engine->prepare_body_parameters( $c, @_ );
1468 }
1469
1470 =head2 $c->prepare_connection
1471
1472 Prepares connection.
1473
1474 =cut
1475
1476 sub prepare_connection {
1477     my $c = shift;
1478     $c->engine->prepare_connection( $c, @_ );
1479 }
1480
1481 =head2 $c->prepare_cookies
1482
1483 Prepares cookies.
1484
1485 =cut
1486
1487 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1488
1489 =head2 $c->prepare_headers
1490
1491 Prepares headers.
1492
1493 =cut
1494
1495 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1496
1497 =head2 $c->prepare_parameters
1498
1499 Prepares parameters.
1500
1501 =cut
1502
1503 sub prepare_parameters {
1504     my $c = shift;
1505     $c->prepare_body_parameters;
1506     $c->engine->prepare_parameters( $c, @_ );
1507 }
1508
1509 =head2 $c->prepare_path
1510
1511 Prepares path and base.
1512
1513 =cut
1514
1515 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1516
1517 =head2 $c->prepare_query_parameters
1518
1519 Prepares query parameters.
1520
1521 =cut
1522
1523 sub prepare_query_parameters {
1524     my $c = shift;
1525
1526     $c->engine->prepare_query_parameters( $c, @_ );
1527
1528     if ( $c->debug && keys %{ $c->request->query_parameters } ) {
1529         my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1530         for my $key ( sort keys %{ $c->req->query_parameters } ) {
1531             my $param = $c->req->query_parameters->{$key};
1532             my $value = defined($param) ? $param : '';
1533             $t->row( $key,
1534                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1535         }
1536         $c->log->debug( "Query Parameters are:\n" . $t->draw );
1537     }
1538 }
1539
1540 =head2 $c->prepare_read
1541
1542 Prepares the input for reading.
1543
1544 =cut
1545
1546 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1547
1548 =head2 $c->prepare_request
1549
1550 Prepares the engine request.
1551
1552 =cut
1553
1554 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1555
1556 =head2 $c->prepare_uploads
1557
1558 Prepares uploads.
1559
1560 =cut
1561
1562 sub prepare_uploads {
1563     my $c = shift;
1564
1565     $c->engine->prepare_uploads( $c, @_ );
1566
1567     if ( $c->debug && keys %{ $c->request->uploads } ) {
1568         my $t = Text::SimpleTable->new(
1569             [ 12, 'Key' ],
1570             [ 28, 'Filename' ],
1571             [ 18, 'Type' ],
1572             [ 9,  'Size' ]
1573         );
1574         for my $key ( sort keys %{ $c->request->uploads } ) {
1575             my $upload = $c->request->uploads->{$key};
1576             for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1577                 $t->row( $key, $u->filename, $u->type, $u->size );
1578             }
1579         }
1580         $c->log->debug( "File Uploads are:\n" . $t->draw );
1581     }
1582 }
1583
1584 =head2 $c->prepare_write
1585
1586 Prepares the output for writing.
1587
1588 =cut
1589
1590 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1591
1592 =head2 $c->request_class
1593
1594 Returns or sets the request class.
1595
1596 =head2 $c->response_class
1597
1598 Returns or sets the response class.
1599
1600 =head2 $c->read( [$maxlength] )
1601
1602 Reads a chunk of data from the request body. This method is designed to
1603 be used in a while loop, reading C<$maxlength> bytes on every call.
1604 C<$maxlength> defaults to the size of the request if not specified.
1605
1606 You have to set C<MyApp-E<gt>config-E<gt>{parse_on_demand}> to use this
1607 directly.
1608
1609 =cut
1610
1611 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1612
1613 =head2 $c->run
1614
1615 Starts the engine.
1616
1617 =cut
1618
1619 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1620
1621 =head2 $c->set_action( $action, $code, $namespace, $attrs )
1622
1623 Sets an action in a given namespace.
1624
1625 =cut
1626
1627 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1628
1629 =head2 $c->setup_actions($component)
1630
1631 Sets up actions for a component.
1632
1633 =cut
1634
1635 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1636
1637 =head2 $c->setup_components
1638
1639 Sets up components.
1640
1641 =cut
1642
1643 sub setup_components {
1644     my $class = shift;
1645
1646     my $callback = sub {
1647         my ( $component, $context ) = @_;
1648
1649         unless ( $component->can('COMPONENT') ) {
1650             return $component;
1651         }
1652
1653         my $suffix = Catalyst::Utils::class2classsuffix($component);
1654         my $config = $class->config->{$suffix} || {};
1655
1656         my $instance;
1657
1658         eval { $instance = $component->COMPONENT( $context, $config ); };
1659
1660         if ( my $error = $@ ) {
1661
1662             chomp $error;
1663
1664             Catalyst::Exception->throw( message =>
1665                   qq/Couldn't instantiate component "$component", "$error"/ );
1666         }
1667
1668         Catalyst::Exception->throw( message =>
1669 qq/Couldn't instantiate component "$component", "COMPONENT() didn't return a object"/
1670           )
1671           unless ref $instance;
1672         return $instance;
1673     };
1674
1675     eval "package $class;\n" . q!Module::Pluggable::Fast->import(
1676             name   => '_catalyst_components',
1677             search => [
1678                 "$class\::Controller", "$class\::C",
1679                 "$class\::Model",      "$class\::M",
1680                 "$class\::View",       "$class\::V"
1681             ],
1682             callback => $callback
1683         );
1684     !;
1685
1686     if ( my $error = $@ ) {
1687
1688         chomp $error;
1689
1690         Catalyst::Exception->throw(
1691             message => qq/Couldn't load components "$error"/ );
1692     }
1693
1694     for my $component ( $class->_catalyst_components($class) ) {
1695         $class->components->{ ref $component || $component } = $component;
1696     }
1697 }
1698
1699 =head2 $c->setup_dispatcher
1700
1701 Sets up dispatcher.
1702
1703 =cut
1704
1705 sub setup_dispatcher {
1706     my ( $class, $dispatcher ) = @_;
1707
1708     if ($dispatcher) {
1709         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1710     }
1711
1712     if ( $ENV{CATALYST_DISPATCHER} ) {
1713         $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1714     }
1715
1716     if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1717         $dispatcher =
1718           'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1719     }
1720
1721     unless ($dispatcher) {
1722         $dispatcher = $class->dispatcher_class;
1723     }
1724
1725     $dispatcher->require;
1726
1727     if ($@) {
1728         Catalyst::Exception->throw(
1729             message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1730     }
1731
1732     # dispatcher instance
1733     $class->dispatcher( $dispatcher->new );
1734 }
1735
1736 =head2 $c->setup_engine
1737
1738 Sets up engine.
1739
1740 =cut
1741
1742 sub setup_engine {
1743     my ( $class, $engine ) = @_;
1744
1745     if ($engine) {
1746         $engine = 'Catalyst::Engine::' . $engine;
1747     }
1748
1749     if ( $ENV{CATALYST_ENGINE} ) {
1750         $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1751     }
1752
1753     if ( $ENV{ uc($class) . '_ENGINE' } ) {
1754         $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1755     }
1756
1757     if ( $ENV{MOD_PERL} ) {
1758
1759         # create the apache method
1760         {
1761             no strict 'refs';
1762             *{"$class\::apache"} = sub { shift->engine->apache };
1763         }
1764
1765         my ( $software, $version ) =
1766           $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1767
1768         $version =~ s/_//g;
1769         $version =~ s/(\.[^.]+)\./$1/g;
1770
1771         if ( $software eq 'mod_perl' ) {
1772
1773             if ( !$engine ) {
1774
1775                 if ( $version >= 1.99922 ) {
1776                     $engine = 'Catalyst::Engine::Apache2::MP20';
1777                 }
1778
1779                 elsif ( $version >= 1.9901 ) {
1780                     $engine = 'Catalyst::Engine::Apache2::MP19';
1781                 }
1782
1783                 elsif ( $version >= 1.24 ) {
1784                     $engine = 'Catalyst::Engine::Apache::MP13';
1785                 }
1786
1787                 else {
1788                     Catalyst::Exception->throw( message =>
1789                           qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1790                 }
1791
1792             }
1793
1794             # install the correct mod_perl handler
1795             if ( $version >= 1.9901 ) {
1796                 *handler = sub  : method {
1797                     shift->handle_request(@_);
1798                 };
1799             }
1800             else {
1801                 *handler = sub ($$) { shift->handle_request(@_) };
1802             }
1803
1804         }
1805
1806         elsif ( $software eq 'Zeus-Perl' ) {
1807             $engine = 'Catalyst::Engine::Zeus';
1808         }
1809
1810         else {
1811             Catalyst::Exception->throw(
1812                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1813         }
1814     }
1815
1816     unless ($engine) {
1817         $engine = $class->engine_class;
1818     }
1819
1820     $engine->require;
1821
1822     if ($@) {
1823         Catalyst::Exception->throw( message =>
1824 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1825         );
1826     }
1827
1828     # check for old engines that are no longer compatible
1829     my $old_engine;
1830     if ( $engine->isa('Catalyst::Engine::Apache')
1831         && !Catalyst::Engine::Apache->VERSION )
1832     {
1833         $old_engine = 1;
1834     }
1835
1836     elsif ( $engine->isa('Catalyst::Engine::Server::Base')
1837         && Catalyst::Engine::Server->VERSION le '0.02' )
1838     {
1839         $old_engine = 1;
1840     }
1841
1842     elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
1843         && $engine->VERSION eq '0.01' )
1844     {
1845         $old_engine = 1;
1846     }
1847
1848     elsif ($engine->isa('Catalyst::Engine::Zeus')
1849         && $engine->VERSION eq '0.01' )
1850     {
1851         $old_engine = 1;
1852     }
1853
1854     if ($old_engine) {
1855         Catalyst::Exception->throw( message =>
1856               qq/Engine "$engine" is not supported by this version of Catalyst/
1857         );
1858     }
1859
1860     # engine instance
1861     $class->engine( $engine->new );
1862 }
1863
1864 =head2 $c->setup_home
1865
1866 Sets up the home directory.
1867
1868 =cut
1869
1870 sub setup_home {
1871     my ( $class, $home ) = @_;
1872
1873     if ( $ENV{CATALYST_HOME} ) {
1874         $home = $ENV{CATALYST_HOME};
1875     }
1876
1877     if ( $ENV{ uc($class) . '_HOME' } ) {
1878         $home = $ENV{ uc($class) . '_HOME' };
1879     }
1880
1881     unless ($home) {
1882         $home = Catalyst::Utils::home($class);
1883     }
1884
1885     if ($home) {
1886         $class->config->{home} ||= $home;
1887         $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
1888     }
1889 }
1890
1891 =head2 $c->setup_log
1892
1893 Sets up log.
1894
1895 =cut
1896
1897 sub setup_log {
1898     my ( $class, $debug ) = @_;
1899
1900     unless ( $class->log ) {
1901         $class->log( Catalyst::Log->new );
1902     }
1903
1904     my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
1905
1906     if (
1907           ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
1908         ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
1909         : $debug
1910       )
1911     {
1912         no strict 'refs';
1913         *{"$class\::debug"} = sub { 1 };
1914         $class->log->debug('Debug messages enabled');
1915     }
1916 }
1917
1918 =head2 $c->setup_plugins
1919
1920 Sets up plugins.
1921
1922 =cut
1923
1924 =head2 $c->registered_plugins
1925
1926 Returns a sorted list of the plugins which have either been stated in the
1927 import list or which have been added via C<< MyApp->plugin(@args); >>.
1928
1929 If passed a given plugin name, it will report a boolean value indicating
1930 whether or not that plugin is loaded.  A fully qualified name is required if
1931 the plugin name does not begin with C<Catalyst::Plugin::>.
1932
1933  if ($c->registered_plugins('Some::Plugin')) {
1934      ...
1935  }
1936
1937 =cut
1938
1939 {
1940
1941     sub registered_plugins {
1942         my $proto = shift;
1943         return sort keys %{$proto->_plugins} unless @_;
1944         my $plugin = shift;
1945         return 1 if exists $proto->_plugins->{$plugin};
1946         return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
1947     }
1948
1949     sub _register_plugin {
1950         my ( $proto, $plugin, $instant ) = @_;
1951         my $class = ref $proto || $proto;
1952
1953         $plugin->require;
1954
1955         if ( my $error = $@ ) {
1956             my $type = $instant ? "instant " : '';
1957             Catalyst::Exception->throw(
1958                 message => qq/Couldn't load ${type}plugin "$plugin", $error/ );
1959         }
1960
1961         $proto->_plugins->{$plugin} = 1;
1962         unless ($instant) {
1963             no strict 'refs';
1964             unshift @{"$class\::ISA"}, $plugin;
1965         }
1966         return $class;
1967     }
1968
1969     sub setup_plugins {
1970         my ( $class, $plugins ) = @_;
1971
1972         $class->_plugins( {} ) unless $class->_plugins;
1973         $plugins ||= [];
1974         for my $plugin ( reverse @$plugins ) {
1975
1976             unless ( $plugin =~ s/\A\+// ) {
1977                 $plugin = "Catalyst::Plugin::$plugin";
1978             }
1979
1980             $class->_register_plugin($plugin);
1981         }
1982     }
1983 }
1984
1985 =head2 $c->stack
1986
1987 Returns an arrayref of the internal execution stack (actions that are currently
1988 executing).
1989
1990 =head2 $c->write( $data )
1991
1992 Writes $data to the output stream. When using this method directly, you
1993 will need to manually set the C<Content-Length> header to the length of
1994 your output data, if known.
1995
1996 =cut
1997
1998 sub write {
1999     my $c = shift;
2000
2001     # Finalize headers if someone manually writes output
2002     $c->finalize_headers;
2003
2004     return $c->engine->write( $c, @_ );
2005 }
2006
2007 =head2 version
2008
2009 Returns the Catalyst version number. Mostly useful for "powered by"
2010 messages in template systems.
2011
2012 =cut
2013
2014 sub version { return $Catalyst::VERSION }
2015
2016 =head1 INTERNAL ACTIONS
2017
2018 Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
2019 C<_ACTION>, and C<_END>. These are by default not shown in the private
2020 action table, but you can make them visible with a config parameter.
2021
2022     MyApp->config->{show_internal_actions} = 1;
2023
2024 =head1 CASE SENSITIVITY
2025
2026 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
2027 mapped to C</foo/bar>. You can activate case sensitivity with a config
2028 parameter.
2029
2030     MyApp->config->{case_sensitive} = 1;
2031
2032 This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
2033
2034 =head1 ON-DEMAND PARSER
2035
2036 The request body is usually parsed at the beginning of a request,
2037 but if you want to handle input yourself or speed things up a bit,
2038 you can enable on-demand parsing with a config parameter.
2039
2040     MyApp->config->{parse_on_demand} = 1;
2041
2042 =head1 PROXY SUPPORT
2043
2044 Many production servers operate using the common double-server approach,
2045 with a lightweight frontend web server passing requests to a larger
2046 backend server. An application running on the backend server must deal
2047 with two problems: the remote user always appears to be C<127.0.0.1> and
2048 the server's hostname will appear to be C<localhost> regardless of the
2049 virtual host that the user connected through.
2050
2051 Catalyst will automatically detect this situation when you are running
2052 the frontend and backend servers on the same machine. The following
2053 changes are made to the request.
2054
2055     $c->req->address is set to the user's real IP address, as read from
2056     the HTTP X-Forwarded-For header.
2057
2058     The host value for $c->req->base and $c->req->uri is set to the real
2059     host, as read from the HTTP X-Forwarded-Host header.
2060
2061 Obviously, your web server must support these headers for this to work.
2062
2063 In a more complex server farm environment where you may have your
2064 frontend proxy server(s) on different machines, you will need to set a
2065 configuration option to tell Catalyst to read the proxied data from the
2066 headers.
2067
2068     MyApp->config->{using_frontend_proxy} = 1;
2069
2070 If you do not wish to use the proxy support at all, you may set:
2071
2072     MyApp->config->{ignore_frontend_proxy} = 1;
2073
2074 =head1 THREAD SAFETY
2075
2076 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
2077 and the standalone forking HTTP server on Windows. We believe the Catalyst
2078 core to be thread-safe.
2079
2080 If you plan to operate in a threaded environment, remember that all other
2081 modules you are using must also be thread-safe. Some modules, most notably
2082 L<DBD::SQLite>, are not thread-safe.
2083
2084 =head1 SUPPORT
2085
2086 IRC:
2087
2088     Join #catalyst on irc.perl.org.
2089
2090 Mailing Lists:
2091
2092     http://lists.rawmode.org/mailman/listinfo/catalyst
2093     http://lists.rawmode.org/mailman/listinfo/catalyst-dev
2094
2095 Web:
2096
2097     http://catalyst.perl.org
2098
2099 Wiki:
2100
2101     http://dev.catalyst.perl.org
2102
2103 =head1 SEE ALSO
2104
2105 =head2 L<Task::Catalyst> - All you need to start with Catalyst
2106
2107 =head2 L<Catalyst::Manual> - The Catalyst Manual
2108
2109 =head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
2110
2111 =head2 L<Catalyst::Engine> - Core engine
2112
2113 =head2 L<Catalyst::Log> - Log class.
2114
2115 =head2 L<Catalyst::Request> - Request object
2116
2117 =head2 L<Catalyst::Response> - Response object
2118
2119 =head2 L<Catalyst::Test> - The test suite.
2120
2121 =head1 CREDITS
2122
2123 Andy Grundman
2124
2125 Andy Wardley
2126
2127 Andreas Marienborg
2128
2129 Andrew Bramble
2130
2131 Andrew Ford
2132
2133 Andrew Ruthven
2134
2135 Arthur Bergman
2136
2137 Autrijus Tang
2138
2139 Brian Cassidy
2140
2141 Carl Franks
2142
2143 Christian Hansen
2144
2145 Christopher Hicks
2146
2147 Dan Sully
2148
2149 Danijel Milicevic
2150
2151 David Kamholz
2152
2153 David Naughton
2154
2155 Drew Taylor
2156
2157 Gary Ashton Jones
2158
2159 Geoff Richards
2160
2161 Jesse Sheidlower
2162
2163 Jesse Vincent
2164
2165 Jody Belka
2166
2167 Johan Lindstrom
2168
2169 Juan Camacho
2170
2171 Leon Brocard
2172
2173 Marcus Ramberg
2174
2175 Matt S Trout
2176
2177 Robert Sedlacek
2178
2179 Sam Vilain
2180
2181 Sascha Kiefer
2182
2183 Tatsuhiko Miyagawa
2184
2185 Ulf Edvinsson
2186
2187 Yuval Kogman
2188
2189 =head1 AUTHOR
2190
2191 Sebastian Riedel, C<sri@oook.de>
2192
2193 =head1 LICENSE
2194
2195 This library is free software, you can redistribute it and/or modify it under
2196 the same terms as Perl itself.
2197
2198 =cut
2199
2200 1;