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