lib/Catalyst.pm

   1 package Catalyst;
   2
   3 use strict;
   4 use base 'Catalyst::Base';
   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 NEXT;
  14 use Text::ASCIITable;
  15 use Path::Class;
  16 use Time::HiRes qw/gettimeofday tv_interval/;
  17 use URI;
  18 use Scalar::Util qw/weaken/;
  19
  20 __PACKAGE__->mk_accessors(qw/counter depth request response state/);
  21
  22 # Laziness++
  23 *comp = \&component;
  24 *req  = \&request;
  25 *res  = \&response;
  26
  27 # For backwards compatibility
  28 *finalize_output = \&finalize_body;
  29
  30 # For statistics
  31 our $COUNT     = 1;
  32 our $START     = time;
  33 our $RECURSION = 1000;
  34 our $DETACH    = "catalyst_detach\n";
  35
  36 require Module::Pluggable::Fast;
  37
  38 # Helper script generation
  39 our $CATALYST_SCRIPT_GEN = 8;
  40
  41 __PACKAGE__->mk_classdata($_)
  42   for qw/components arguments dispatcher engine log/;
  43
  44 our $VERSION = '5.49_01';
  45
  46 sub import {
  47     my ( $class, @arguments ) = @_;
  48
  49     # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
  50     # callers @ISA.
  51     return unless $class eq 'Catalyst';
  52
  53     my $caller = caller(0);
  54
  55     unless ( $caller->isa('Catalyst') ) {
  56         no strict 'refs';
  57         push @{"$caller\::ISA"}, $class;
  58     }
  59
  60     $caller->arguments( [@arguments] );
  61     $caller->setup_home;
  62 }
  63
  64 =head1 NAME
  65
  66 Catalyst - The Elegant MVC Web Application Framework
  67
  68 =head1 SYNOPSIS
  69
  70     # use the helper to start a new application
  71     catalyst.pl MyApp
  72     cd MyApp
  73
  74     # add models, views, controllers
  75     script/myapp_create.pl model Something
  76     script/myapp_create.pl view Stuff
  77     script/myapp_create.pl controller Yada
  78
  79     # built in testserver
  80     script/myapp_server.pl
  81
  82     # command line interface
  83     script/myapp_test.pl /yada
  84
  85
  86     use Catalyst;
  87
  88     use Catalyst qw/My::Module My::OtherModule/;
  89
  90     use Catalyst '-Debug';
  91
  92     use Catalyst qw/-Debug -Engine=CGI/;
  93
  94     sub default : Private { $_[1]->res->output('Hello') } );
  95
  96     sub index : Path('/index.html') {
  97         my ( $self, $c ) = @_;
  98         $c->res->output('Hello');
  99         $c->forward('foo');
 100     }
 101
 102     sub product : Regex('^product[_]*(\d*).html$') {
 103         my ( $self, $c ) = @_;
 104         $c->stash->{template} = 'product.tt';
 105         $c->stash->{product} = $c->req->snippets->[0];
 106     }
 107
 108 See also L<Catalyst::Manual::Intro>
 109
 110 =head1 DESCRIPTION
 111
 112 The key concept of Catalyst is DRY (Don't Repeat Yourself).
 113
 114 See L<Catalyst::Manual> for more documentation.
 115
 116 Catalyst plugins can be loaded by naming them as arguments to the "use Catalyst" statement.
 117 Omit the C<Catalyst::Plugin::> prefix from the plugin name,
 118 so C<Catalyst::Plugin::My::Module> becomes C<My::Module>.
 119
 120     use Catalyst 'My::Module';
 121
 122 Special flags like -Debug and -Engine can also be specified as arguments when
 123 Catalyst is loaded:
 124
 125     use Catalyst qw/-Debug My::Module/;
 126
 127 The position of plugins and flags in the chain is important, because they are
 128 loaded in exactly the order that they appear.
 129
 130 The following flags are supported:
 131
 132 =over 4
 133
 134 =item -Debug
 135
 136 enables debug output, i.e.:
 137
 138     use Catalyst '-Debug';
 139
 140 this is equivalent to:
 141
 142     use Catalyst;
 143     sub debug { 1 }
 144
 145 =item -Dispatcher
 146
 147 Force Catalyst to use a specific dispatcher.
 148
 149 =item -Engine
 150
 151 Force Catalyst to use a specific engine.
 152 Omit the C<Catalyst::Engine::> prefix of the engine name, i.e.:
 153
 154     use Catalyst '-Engine=CGI';
 155
 156 =item -Home
 157
 158 Force Catalyst to use a specific home directory.
 159
 160 =item -Log
 161
 162 Specify log level.
 163
 164 =back
 165
 166 =head1 METHODS
 167
 168 =over 4
 169
 170 =item $c->comp($name)
 171
 172 =item $c->component($name)
 173
 174 Get a component object by name.
 175
 176     $c->comp('MyApp::Model::MyModel')->do_stuff;
 177
 178 =cut
 179
 180 sub component {
 181     my $c = shift;
 182
 183     if (@_) {
 184
 185         my $name = shift;
 186
 187         my $appclass = ref $c || $c;
 188
 189         my @names = (
 190             $name, "${appclass}::${name}",
 191             map { "${appclass}::${_}::${name}" } qw/M V C/
 192         );
 193
 194         foreach my $try (@names) {
 195
 196             if ( exists $c->components->{$try} ) {
 197
 198                 return $c->components->{$try};
 199             }
 200         }
 201
 202         foreach my $component ( keys %{ $c->components } ) {
 203
 204             return $c->components->{$component} if $component =~ /$name/i;
 205         }
 206
 207     }
 208
 209     return sort keys %{ $c->components };
 210 }
 211
 212 =item config
 213
 214 Returns a hashref containing your applications settings.
 215
 216 =item debug
 217
 218 Overload to enable debug messages.
 219
 220 =cut
 221
 222 sub debug { 0 }
 223
 224 =item $c->detach( $command [, \@arguments ] )
 225
 226 Like C<forward> but doesn't return.
 227
 228 =cut
 229
 230 sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
 231
 232 =item $c->dispatcher
 233
 234 Contains the dispatcher instance.
 235 Stringifies to class.
 236
 237 =item $c->forward( $command [, \@arguments ] )
 238
 239 Forward processing to a private action or a method from a class.
 240 If you define a class without method it will default to process().
 241 also takes an optional arrayref containing arguments to be passed
 242 to the new function. $c->req->args will be reset upon returning
 243 from the function.
 244
 245     $c->forward('/foo');
 246     $c->forward('index');
 247     $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
 248     $c->forward('MyApp::View::TT');
 249
 250 =cut
 251
 252 sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
 253
 254 =item $c->setup
 255
 256 Setup.
 257
 258     $c->setup;
 259
 260 =cut
 261
 262 sub setup {
 263     my ( $class, @arguments ) = @_;
 264
 265     unless ( $class->isa('Catalyst') ) {
 266
 267         Catalyst::Exception->throw(
 268             message => qq/'$class' does not inherit from Catalyst/ );
 269     }
 270
 271     if ( $class->arguments ) {
 272         @arguments = ( @arguments, @{ $class->arguments } );
 273     }
 274
 275     # Process options
 276     my $flags = {};
 277
 278     foreach (@arguments) {
 279
 280         if (/^-Debug$/) {
 281             $flags->{log} =
 282               ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
 283         }
 284         elsif (/^-(\w+)=?(.*)$/) {
 285             $flags->{ lc $1 } = $2;
 286         }
 287         else {
 288             push @{ $flags->{plugins} }, $_;
 289         }
 290     }
 291
 292     $class->setup_log( delete $flags->{log} );
 293     $class->setup_plugins( delete $flags->{plugins} );
 294     $class->setup_dispatcher( delete $flags->{dispatcher} );
 295     $class->setup_engine( delete $flags->{engine} );
 296     $class->setup_home( delete $flags->{home} );
 297
 298     for my $flag ( sort keys %{$flags} ) {
 299
 300         if ( my $code = $class->can( 'setup_' . $flag ) ) {
 301             &$code( $class, delete $flags->{$flag} );
 302         }
 303         else {
 304             $class->log->warn(qq/Unknown flag "$flag"/);
 305         }
 306     }
 307
 308     $class->log->warn( "You are running an old helper script! "
 309           . "Please update your scripts by regenerating the "
 310           . "application and copying over the new scripts." )
 311       if ( $ENV{CATALYST_SCRIPT_GEN}
 312         && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::CATALYST_SCRIPT_GEN ) );
 313
 314     if ( $class->debug ) {
 315
 316         my @plugins = ();
 317
 318         {
 319             no strict 'refs';
 320             @plugins = grep { /^Catalyst::Plugin/ } @{"$class\::ISA"};
 321         }
 322
 323         if (@plugins) {
 324             my $t = Text::ASCIITable->new;
 325             $t->setOptions( 'hide_HeadRow',  1 );
 326             $t->setOptions( 'hide_HeadLine', 1 );
 327             $t->setCols('Class');
 328             $t->setColWidth( 'Class', 75, 1 );
 329             $t->addRow($_) for @plugins;
 330             $class->log->debug( "Loaded plugins:\n" . $t->draw );
 331         }
 332
 333         my $dispatcher = $class->dispatcher;
 334         my $engine     = $class->engine;
 335         my $home       = $class->config->{home};
 336
 337         $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
 338         $class->log->debug(qq/Loaded engine "$engine"/);
 339
 340         $home
 341           ? ( -d $home )
 342           ? $class->log->debug(qq/Found home "$home"/)
 343           : $class->log->debug(qq/Home "$home" doesn't exist/)
 344           : $class->log->debug(q/Couldn't find home/);
 345     }
 346
 347     # Call plugins setup
 348     {
 349         no warnings qw/redefine/;
 350         local *setup = sub { };
 351         $class->setup;
 352     }
 353
 354     # Initialize our data structure
 355     $class->components( {} );
 356
 357     $class->setup_components;
 358
 359     if ( $class->debug ) {
 360         my $t = Text::ASCIITable->new;
 361         $t->setOptions( 'hide_HeadRow',  1 );
 362         $t->setOptions( 'hide_HeadLine', 1 );
 363         $t->setCols('Class');
 364         $t->setColWidth( 'Class', 75, 1 );
 365         $t->addRow($_) for sort keys %{ $class->components };
 366         $class->log->debug( "Loaded components:\n" . $t->draw )
 367           if ( @{ $t->{tbl_rows} } );
 368     }
 369
 370     # Add our self to components, since we are also a component
 371     $class->components->{$class} = $class;
 372
 373     $class->setup_actions;
 374
 375     if ( $class->debug ) {
 376         my $name = $class->config->{name} || 'Application';
 377         $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
 378     }
 379     $class->log->_flush() if $class->log->can('_flush');
 380 }
 381
 382 =item $c->uri_for($path)
 383
 384 Merges path with $c->request->base for absolute uri's and with
 385 $c->request->match for relative uri's, then returns a normalized
 386 L<URI> object.
 387
 388 =cut
 389
 390 sub uri_for {
 391     my ( $c, $path ) = @_;
 392     my $base     = $c->request->base->clone;
 393     my $basepath = $base->path;
 394     $basepath =~ s/\/$//;
 395     $basepath .= '/';
 396     my $match = $c->request->match;
 397     $match =~ s/^\///;
 398     $match .= '/' if $match;
 399     $match = '' if $path =~ /^\//;
 400     $path =~ s/^\///;
 401     return URI->new_abs( URI->new_abs( $path, "$basepath$match" ), $base )
 402       ->canonical;
 403 }
 404
 405 =item $c->error
 406
 407 =item $c->error($error, ...)
 408
 409 =item $c->error($arrayref)
 410
 411 Returns an arrayref containing error messages.
 412
 413     my @error = @{ $c->error };
 414
 415 Add a new error.
 416
 417     $c->error('Something bad happened');
 418
 419 =cut
 420
 421 sub error {
 422     my $c = shift;
 423     my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
 424     push @{ $c->{error} }, @$error;
 425     return $c->{error};
 426 }
 427
 428 =item $c->engine
 429
 430 Contains the engine instance.
 431 Stringifies to the class.
 432
 433 =item $c->log
 434
 435 Contains the logging object.  Unless it is already set Catalyst sets this up with a
 436 C<Catalyst::Log> object.  To use your own log class:
 437
 438     $c->log( MyLogger->new );
 439     $c->log->info("now logging with my own logger!");
 440
 441 Your log class should implement the methods described in the C<Catalyst::Log>
 442 man page.
 443
 444 =item $c->plugin( $name, $class, @args )
 445
 446 Instant plugins for Catalyst.
 447 Classdata accessor/mutator will be created, class loaded and instantiated.
 448
 449     MyApp->plugin( 'prototype', 'HTML::Prototype' );
 450
 451     $c->prototype->define_javascript_functions;
 452
 453 =cut
 454
 455 sub plugin {
 456     my ( $class, $name, $plugin, @args ) = @_;
 457     $plugin->require;
 458
 459     if ( my $error = $UNIVERSAL::require::ERROR ) {
 460         Catalyst::Exception->throw(
 461             message => qq/Couldn't load instant plugin "$plugin", "$error"/ );
 462     }
 463
 464     eval { $plugin->import };
 465     $class->mk_classdata($name);
 466     my $obj;
 467     eval { $obj = $plugin->new(@args) };
 468
 469     if ($@) {
 470         Catalyst::Exception->throw( message =>
 471               qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
 472     }
 473
 474     $class->$name($obj);
 475     $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
 476       if $class->debug;
 477 }
 478
 479 =item $c->request
 480
 481 =item $c->req
 482
 483 Returns a C<Catalyst::Request> object.
 484
 485     my $req = $c->req;
 486
 487 =item $c->response
 488
 489 =item $c->res
 490
 491 Returns a C<Catalyst::Response> object.
 492
 493     my $res = $c->res;
 494
 495 =item $c->state
 496
 497 Contains the return value of the last executed action.
 498
 499 =item $c->stash
 500
 501 Returns a hashref containing all your data.
 502
 503     $c->stash->{foo} ||= 'yada';
 504     print $c->stash->{foo};
 505
 506 =cut
 507
 508 sub stash {
 509     my $c = shift;
 510     if (@_) {
 511         my $stash = @_ > 1 ? {@_} : $_[0];
 512         while ( my ( $key, $val ) = each %$stash ) {
 513             $c->{stash}->{$key} = $val;
 514         }
 515     }
 516     return $c->{stash};
 517 }
 518
 519 =back
 520
 521 =head1 INTERNAL METHODS
 522
 523 =over 4
 524
 525 =item $c->benchmark($coderef)
 526
 527 Takes a coderef with arguments and returns elapsed time as float.
 528
 529     my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
 530     $c->log->info( sprintf "Processing took %f seconds", $elapsed );
 531
 532 =cut
 533
 534 sub benchmark {
 535     my $c       = shift;
 536     my $code    = shift;
 537     my $time    = [gettimeofday];
 538     my @return  = &$code(@_);
 539     my $elapsed = tv_interval $time;
 540     return wantarray ? ( $elapsed, @return ) : $elapsed;
 541 }
 542
 543 =item $c->components
 544
 545 Contains the components.
 546
 547 =item $c->counter
 548
 549 Returns a hashref containing coderefs and execution counts.
 550 (Needed for deep recursion detection)
 551
 552 =item $c->depth
 553
 554 Returns the actual forward depth.
 555
 556 =item $c->dispatch
 557
 558 Dispatch request to actions.
 559
 560 =cut
 561
 562 sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
 563
 564 =item $c->execute($class, $coderef)
 565
 566 Execute a coderef in given class and catch exceptions.
 567 Errors are available via $c->error.
 568
 569 =cut
 570
 571 sub execute {
 572     my ( $c, $class, $code ) = @_;
 573     $class = $c->components->{$class} || $class;
 574     $c->state(0);
 575     my $callsub = ( caller(1) )[3];
 576
 577     my $action = '';
 578     if ( $c->debug ) {
 579         $action = "$code";
 580         $action = "/$action" unless $action =~ /\-\>/;
 581         $c->counter->{"$code"}++;
 582
 583         if ( $c->counter->{"$code"} > $RECURSION ) {
 584             my $error = qq/Deep recursion detected in "$action"/;
 585             $c->log->error($error);
 586             $c->error($error);
 587             $c->state(0);
 588             return $c->state;
 589         }
 590
 591         $action = "-> $action" if $callsub =~ /forward$/;
 592     }
 593     $c->{depth}++;
 594     eval {
 595         if ( $c->debug )
 596         {
 597             my ( $elapsed, @state ) =
 598               $c->benchmark( $code, $class, $c, @{ $c->req->args } );
 599             push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
 600             $c->state(@state);
 601         }
 602         else { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }
 603     };
 604     $c->{depth}--;
 605
 606     if ( my $error = $@ ) {
 607
 608         if ( $error eq $DETACH ) { die $DETACH if $c->{depth} > 1 }
 609         else {
 610             unless ( ref $error ) {
 611                 chomp $error;
 612                 $error = qq/Caught exception "$error"/;
 613             }
 614
 615             $c->log->error($error);
 616             $c->error($error);
 617             $c->state(0);
 618         }
 619     }
 620     return $c->state;
 621 }
 622
 623 =item $c->finalize
 624
 625 Finalize request.
 626
 627 =cut
 628
 629 sub finalize {
 630     my $c = shift;
 631
 632     $c->finalize_uploads;
 633
 634     # Error
 635     if ( $#{ $c->error } >= 0 ) {
 636         $c->finalize_error;
 637     }
 638
 639     $c->finalize_headers;
 640
 641     # HEAD request
 642     if ( $c->request->method eq 'HEAD' ) {
 643         $c->response->body('');
 644     }
 645
 646     $c->finalize_body;
 647
 648     return $c->response->status;
 649 }
 650
 651 =item $c->finalize_body
 652
 653 Finalize body.
 654
 655 =cut
 656
 657 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
 658
 659 =item $c->finalize_cookies
 660
 661 Finalize cookies.
 662
 663 =cut
 664
 665 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
 666
 667 =item $c->finalize_error
 668
 669 Finalize error.
 670
 671 =cut
 672
 673 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
 674
 675 =item $c->finalize_headers
 676
 677 Finalize headers.
 678
 679 =cut
 680
 681 sub finalize_headers {
 682     my $c = shift;
 683
 684     # Check if we already finalized headers
 685     return if $c->response->{_finalized_headers};
 686
 687     # Handle redirects
 688     if ( my $location = $c->response->redirect ) {
 689         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
 690         $c->response->header( Location => $location );
 691     }
 692
 693     # Content-Length
 694     if ( $c->response->body && !$c->response->content_length ) {
 695         $c->response->content_length( bytes::length( $c->response->body ) );
 696     }
 697
 698     # Errors
 699     if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
 700         $c->response->headers->remove_header("Content-Length");
 701         $c->response->body('');
 702     }
 703
 704     $c->finalize_cookies;
 705
 706     $c->engine->finalize_headers( $c, @_ );
 707
 708     # Done
 709     $c->response->{_finalized_headers} = 1;
 710 }
 711
 712 =item $c->finalize_output
 713
 714 An alias for finalize_body.
 715
 716 =item $c->finalize_read
 717
 718 Finalize the input after reading is complete.
 719
 720 =cut
 721
 722 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
 723
 724 =item $c->finalize_uploads
 725
 726 Finalize uploads.  Cleans up any temporary files.
 727
 728 =cut
 729
 730 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
 731
 732 =item $c->get_action( $action, $namespace, $inherit )
 733
 734 Get an action in a given namespace.
 735
 736 =cut
 737
 738 sub get_action { my $c = shift; $c->dispatcher->get_action( $c, @_ ) }
 739
 740 =item handle_request( $class, @arguments )
 741
 742 Handles the request.
 743
 744 =cut
 745
 746 sub handle_request {
 747     my ( $class, @arguments ) = @_;
 748
 749     # Always expect worst case!
 750     my $status = -1;
 751     eval {
 752         my @stats = ();
 753
 754         my $handler = sub {
 755             my $c = $class->prepare(@arguments);
 756             $c->{stats} = \@stats;
 757             $c->dispatch;
 758             return $c->finalize;
 759         };
 760
 761         if ( $class->debug ) {
 762             my $elapsed;
 763             ( $elapsed, $status ) = $class->benchmark($handler);
 764             $elapsed = sprintf '%f', $elapsed;
 765             my $av = sprintf '%.3f',
 766               ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
 767             my $t = Text::ASCIITable->new;
 768             $t->setCols( 'Action', 'Time' );
 769             $t->setColWidth( 'Action', 64, 1 );
 770             $t->setColWidth( 'Time',   9,  1 );
 771
 772             for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
 773             $class->log->info(
 774                 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
 775         }
 776         else { $status = &$handler }
 777
 778     };
 779
 780     if ( my $error = $@ ) {
 781         chomp $error;
 782         $class->log->error(qq/Caught exception in engine "$error"/);
 783     }
 784
 785     $COUNT++;
 786     $class->log->_flush() if $class->log->can('_flush');
 787     return $status;
 788 }
 789
 790 =item $c->prepare(@arguments)
 791
 792 Turns the engine-specific request( Apache, CGI ... )
 793 into a Catalyst context .
 794
 795 =cut
 796
 797 sub prepare {
 798     my ( $class, @arguments ) = @_;
 799
 800     my $c = bless {
 801         counter => {},
 802         depth   => 0,
 803         request => Catalyst::Request->new(
 804             {
 805                 arguments        => [],
 806                 body_parameters  => {},
 807                 cookies          => {},
 808                 headers          => HTTP::Headers->new,
 809                 parameters       => {},
 810                 query_parameters => {},
 811                 secure           => 0,
 812                 snippets         => [],
 813                 uploads          => {}
 814             }
 815         ),
 816         response => Catalyst::Response->new(
 817             {
 818                 body    => '',
 819                 cookies => {},
 820                 headers => HTTP::Headers->new(),
 821                 status  => 200
 822             }
 823         ),
 824         stash => {},
 825         state => 0
 826     }, $class;
 827
 828     # For on-demand data
 829     $c->request->{_context}  = $c;
 830     $c->response->{_context} = $c;
 831     weaken( $c->request->{_context} );
 832     weaken( $c->response->{_context} );
 833
 834     if ( $c->debug ) {
 835         my $secs = time - $START || 1;
 836         my $av = sprintf '%.3f', $COUNT / $secs;
 837         $c->log->debug('**********************************');
 838         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 839         $c->log->debug('**********************************');
 840         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 841     }
 842
 843     $c->prepare_request(@arguments);
 844     $c->prepare_connection;
 845     $c->prepare_query_parameters;
 846     $c->prepare_headers;
 847     $c->prepare_cookies;
 848     $c->prepare_path;
 849
 850     # On-demand parsing
 851     $c->prepare_body unless $c->config->{parse_on_demand};
 852
 853     $c->prepare_action;
 854     my $method  = $c->req->method  || '';
 855     my $path    = $c->req->path    || '';
 856     my $address = $c->req->address || '';
 857
 858     $c->log->debug(qq/"$method" request for "$path" from $address/)
 859       if $c->debug;
 860
 861     return $c;
 862 }
 863
 864 =item $c->prepare_action
 865
 866 Prepare action.
 867
 868 =cut
 869
 870 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
 871
 872 =item $c->prepare_body
 873
 874 Prepare message body.
 875
 876 =cut
 877
 878 sub prepare_body {
 879     my $c = shift;
 880
 881     # Do we run for the first time?
 882     return if defined $c->request->{_body};
 883
 884     # Initialize on-demand data
 885     $c->engine->prepare_body( $c, @_ );
 886     $c->prepare_parameters;
 887     $c->prepare_uploads;
 888
 889     if ( $c->debug && keys %{ $c->req->body_parameters } ) {
 890         my $t = Text::ASCIITable->new;
 891         $t->setCols( 'Key', 'Value' );
 892         $t->setColWidth( 'Key',   37, 1 );
 893         $t->setColWidth( 'Value', 36, 1 );
 894         $t->alignCol( 'Value', 'right' );
 895         for my $key ( sort keys %{ $c->req->body_parameters } ) {
 896             my $param = $c->req->body_parameters->{$key};
 897             my $value = defined($param) ? $param : '';
 898             $t->addRow( $key,
 899                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
 900         }
 901         $c->log->debug( "Body Parameters are:\n" . $t->draw );
 902     }
 903 }
 904
 905 =item $c->prepare_body_chunk( $chunk )
 906
 907 Prepare a chunk of data before sending it to HTTP::Body.
 908
 909 =cut
 910
 911 sub prepare_body_chunk {
 912     my $c = shift;
 913     $c->engine->prepare_body_chunk( $c, @_ );
 914 }
 915
 916 =item $c->prepare_body_parameters
 917
 918 Prepare body parameters.
 919
 920 =cut
 921
 922 sub prepare_body_parameters {
 923     my $c = shift;
 924     $c->engine->prepare_body_parameters( $c, @_ );
 925 }
 926
 927 =item $c->prepare_connection
 928
 929 Prepare connection.
 930
 931 =cut
 932
 933 sub prepare_connection {
 934     my $c = shift;
 935     $c->engine->prepare_connection( $c, @_ );
 936 }
 937
 938 =item $c->prepare_cookies
 939
 940 Prepare cookies.
 941
 942 =cut
 943
 944 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
 945
 946 =item $c->prepare_headers
 947
 948 Prepare headers.
 949
 950 =cut
 951
 952 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
 953
 954 =item $c->prepare_parameters
 955
 956 Prepare parameters.
 957
 958 =cut
 959
 960 sub prepare_parameters {
 961     my $c = shift;
 962     $c->prepare_body_parameters;
 963     $c->engine->prepare_parameters( $c, @_ );
 964 }
 965
 966 =item $c->prepare_path
 967
 968 Prepare path and base.
 969
 970 =cut
 971
 972 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
 973
 974 =item $c->prepare_query_parameters
 975
 976 Prepare query parameters.
 977
 978 =cut
 979
 980 sub prepare_query_parameters {
 981     my $c = shift;
 982
 983     $c->engine->prepare_query_parameters( $c, @_ );
 984
 985     if ( $c->debug && keys %{ $c->request->query_parameters } ) {
 986         my $t = Text::ASCIITable->new;
 987         $t->setCols( 'Key', 'Value' );
 988         $t->setColWidth( 'Key',   37, 1 );
 989         $t->setColWidth( 'Value', 36, 1 );
 990         $t->alignCol( 'Value', 'right' );
 991         for my $key ( sort keys %{ $c->req->query_parameters } ) {
 992             my $param = $c->req->query_parameters->{$key};
 993             my $value = defined($param) ? $param : '';
 994             $t->addRow( $key,
 995                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
 996         }
 997         $c->log->debug( "Query Parameters are:\n" . $t->draw );
 998     }
 999 }
1000
1001 =item $c->prepare_read
1002
1003 Prepare the input for reading.
1004
1005 =cut
1006
1007 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1008
1009 =item $c->prepare_request
1010
1011 Prepare the engine request.
1012
1013 =cut
1014
1015 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1016
1017 =item $c->prepare_uploads
1018
1019 Prepare uploads.
1020
1021 =cut
1022
1023 sub prepare_uploads {
1024     my $c = shift;
1025
1026     $c->engine->prepare_uploads( $c, @_ );
1027
1028     if ( $c->debug && keys %{ $c->request->uploads } ) {
1029         my $t = Text::ASCIITable->new;
1030         $t->setCols( 'Key', 'Filename', 'Type', 'Size' );
1031         $t->setColWidth( 'Key',      12, 1 );
1032         $t->setColWidth( 'Filename', 28, 1 );
1033         $t->setColWidth( 'Type',     18, 1 );
1034         $t->setColWidth( 'Size',     9,  1 );
1035         $t->alignCol( 'Size', 'left' );
1036         for my $key ( sort keys %{ $c->request->uploads } ) {
1037             my $upload = $c->request->uploads->{$key};
1038             for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1039                 $t->addRow( $key, $u->filename, $u->type, $u->size );
1040             }
1041         }
1042         $c->log->debug( "File Uploads are:\n" . $t->draw );
1043     }
1044 }
1045
1046 =item $c->prepare_write
1047
1048 Prepare the output for writing.
1049
1050 =cut
1051
1052 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1053
1054 =item $c->read( [$maxlength] )
1055
1056 Read a chunk of data from the request body.  This method is designed to be
1057 used in a while loop, reading $maxlength bytes on every call.  $maxlength
1058 defaults to the size of the request if not specified.
1059
1060 You have to set MyApp->config->{parse_on_demand} to use this directly.
1061
1062 =cut
1063
1064 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1065
1066 =item $c->run
1067
1068 Starts the engine.
1069
1070 =cut
1071
1072 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1073
1074 =item $c->set_action( $action, $code, $namespace, $attrs )
1075
1076 Set an action in a given namespace.
1077
1078 =cut
1079
1080 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1081
1082 =item $c->setup_actions($component)
1083
1084 Setup actions for a component.
1085
1086 =cut
1087
1088 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1089
1090 =item $c->setup_components
1091
1092 Setup components.
1093
1094 =cut
1095
1096 sub setup_components {
1097     my $class = shift;
1098
1099     my $callback = sub {
1100         my ( $component, $context ) = @_;
1101
1102         unless ( $component->isa('Catalyst::Base') ) {
1103             return $component;
1104         }
1105
1106         my $suffix = Catalyst::Utils::class2classsuffix($component);
1107         my $config = $class->config->{$suffix} || {};
1108
1109         my $instance;
1110
1111         eval { $instance = $component->new( $context, $config ); };
1112
1113         if ( my $error = $@ ) {
1114
1115             chomp $error;
1116
1117             Catalyst::Exception->throw( message =>
1118                   qq/Couldn't instantiate component "$component", "$error"/ );
1119         }
1120
1121         Catalyst::Exception->throw( message =>
1122 qq/Couldn't instantiate component "$component", "new() didn't return a object"/
1123           )
1124           unless ref $instance;
1125         return $instance;
1126     };
1127
1128     eval {
1129         Module::Pluggable::Fast->import(
1130             name   => '_catalyst_components',
1131             search => [
1132                 "$class\::Controller", "$class\::C",
1133                 "$class\::Model",      "$class\::M",
1134                 "$class\::View",       "$class\::V"
1135             ],
1136             callback => $callback
1137         );
1138     };
1139
1140     if ( my $error = $@ ) {
1141
1142         chomp $error;
1143
1144         Catalyst::Exception->throw(
1145             message => qq/Couldn't load components "$error"/ );
1146     }
1147
1148     for my $component ( $class->_catalyst_components($class) ) {
1149         $class->components->{ ref $component || $component } = $component;
1150     }
1151 }
1152
1153 =item $c->setup_dispatcher
1154
1155 =cut
1156
1157 sub setup_dispatcher {
1158     my ( $class, $dispatcher ) = @_;
1159
1160     if ($dispatcher) {
1161         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1162     }
1163
1164     if ( $ENV{CATALYST_DISPATCHER} ) {
1165         $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1166     }
1167
1168     if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1169         $dispatcher =
1170           'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1171     }
1172
1173     unless ($dispatcher) {
1174         $dispatcher = 'Catalyst::Dispatcher';
1175     }
1176
1177     $dispatcher->require;
1178
1179     if ($@) {
1180         Catalyst::Exception->throw(
1181             message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1182     }
1183
1184     # dispatcher instance
1185     $class->dispatcher( $dispatcher->new );
1186 }
1187
1188 =item $c->setup_engine
1189
1190 =cut
1191
1192 sub setup_engine {
1193     my ( $class, $engine ) = @_;
1194
1195     if ($engine) {
1196         $engine = 'Catalyst::Engine::' . $engine;
1197     }
1198
1199     if ( $ENV{CATALYST_ENGINE} ) {
1200         $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1201     }
1202
1203     if ( $ENV{ uc($class) . '_ENGINE' } ) {
1204         $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1205     }
1206
1207     if ( !$engine && $ENV{MOD_PERL} ) {
1208
1209         # create the apache method
1210         {
1211             no strict 'refs';
1212             *{"$class\::apache"} = sub { shift->engine->apache };
1213         }
1214
1215         my ( $software, $version ) =
1216           $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1217
1218         $version =~ s/_//g;
1219         $version =~ s/(\.[^.]+)\./$1/g;
1220
1221         if ( $software eq 'mod_perl' ) {
1222
1223             if ( $version >= 1.99922 ) {
1224                 $engine = 'Catalyst::Engine::Apache2::MP20';
1225             }
1226
1227             elsif ( $version >= 1.9901 ) {
1228                 $engine = 'Catalyst::Engine::Apache2::MP19';
1229             }
1230
1231             elsif ( $version >= 1.24 ) {
1232                 $engine = 'Catalyst::Engine::Apache::MP13';
1233             }
1234
1235             else {
1236                 Catalyst::Exception->throw( message =>
1237                       qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1238             }
1239
1240             # install the correct mod_perl handler
1241             if ( $version >= 1.9901 ) {
1242                 *handler = sub  : method {
1243                     shift->handle_request(@_);
1244                 };
1245             }
1246             else {
1247                 *handler = sub ($$) { shift->handle_request(@_) };
1248             }
1249
1250         }
1251
1252         elsif ( $software eq 'Zeus-Perl' ) {
1253             $engine = 'Catalyst::Engine::Zeus';
1254         }
1255
1256         else {
1257             Catalyst::Exception->throw(
1258                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1259         }
1260     }
1261
1262     unless ($engine) {
1263         $engine = 'Catalyst::Engine::CGI';
1264     }
1265
1266     $engine->require;
1267
1268     if ($@) {
1269         Catalyst::Exception->throw( message =>
1270 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1271         );
1272     }
1273
1274     # engine instance
1275     $class->engine( $engine->new );
1276 }
1277
1278 =item $c->setup_home
1279
1280 =cut
1281
1282 sub setup_home {
1283     my ( $class, $home ) = @_;
1284
1285     if ( $ENV{CATALYST_HOME} ) {
1286         $home = $ENV{CATALYST_HOME};
1287     }
1288
1289     if ( $ENV{ uc($class) . '_HOME' } ) {
1290         $home = $ENV{ uc($class) . '_HOME' };
1291     }
1292
1293     unless ($home) {
1294         $home = Catalyst::Utils::home($class);
1295     }
1296
1297     if ($home) {
1298         $class->config->{home} ||= $home;
1299         $class->config->{root} ||= dir($home)->subdir('root');
1300     }
1301 }
1302
1303 =item $c->setup_log
1304
1305 =cut
1306
1307 sub setup_log {
1308     my ( $class, $debug ) = @_;
1309
1310     unless ( $class->log ) {
1311         $class->log( Catalyst::Log->new );
1312     }
1313
1314     if ( $ENV{CATALYST_DEBUG} || $ENV{ uc($class) . '_DEBUG' } || $debug ) {
1315         no strict 'refs';
1316         *{"$class\::debug"} = sub { 1 };
1317         $class->log->debug('Debug messages enabled');
1318     }
1319 }
1320
1321 =item $c->setup_plugins
1322
1323 =cut
1324
1325 sub setup_plugins {
1326     my ( $class, $plugins ) = @_;
1327
1328     $plugins ||= [];
1329     for my $plugin ( reverse @$plugins ) {
1330
1331         $plugin = "Catalyst::Plugin::$plugin";
1332
1333         $plugin->require;
1334
1335         if ($@) {
1336             Catalyst::Exception->throw(
1337                 message => qq/Couldn't load plugin "$plugin", "$@"/ );
1338         }
1339
1340         {
1341             no strict 'refs';
1342             unshift @{"$class\::ISA"}, $plugin;
1343         }
1344     }
1345 }
1346
1347 =item $c->write( $data )
1348
1349 Writes $data to the output stream.  When using this method directly, you will
1350 need to manually set the Content-Length header to the length of your output
1351 data, if known.
1352
1353 =cut
1354
1355 sub write {
1356     my $c = shift;
1357
1358     # Finalize headers if someone manually writes output
1359     $c->finalize_headers;
1360
1361     return $c->engine->write( $c, @_ );
1362 }
1363
1364 =back
1365
1366 =head1 CASE SENSITIVITY
1367
1368 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> becomes
1369 C</foo/bar>.
1370
1371 But you can activate case sensitivity with a config parameter.
1372
1373     MyApp->config->{case_sensitive} = 1;
1374
1375 So C<MyApp::C::Foo::Bar> becomes C</Foo/Bar>.
1376
1377 =head1 ON-DEMAND PARSER
1378
1379 The request body is usually parsed at the beginning of a request,
1380 but if you want to handle input yourself or speed things up a bit
1381 you can enable on-demand parsing with a config parameter.
1382
1383     MyApp->config->{parse_on_demand} = 1;
1384
1385 =head1 PROXY SUPPORT
1386
1387 Many production servers operate using the common double-server approach, with
1388 a lightweight frontend web server passing requests to a larger backend
1389 server.  An application running on the backend server must deal with two
1390 problems: the remote user always appears to be '127.0.0.1' and the server's
1391 hostname will appear to be 'localhost' regardless of the virtual host the
1392 user connected through.
1393
1394 Catalyst will automatically detect this situation when you are running both
1395 the frontend and backend servers on the same machine.  The following changes
1396 are made to the request.
1397
1398     $c->req->address is set to the user's real IP address, as read from the
1399     HTTP_X_FORWARDED_FOR header.
1400
1401     The host value for $c->req->base and $c->req->uri is set to the real host,
1402     as read from the HTTP_X_FORWARDED_HOST header.
1403
1404 Obviously, your web server must support these 2 headers for this to work.
1405
1406 In a more complex server farm environment where you may have your frontend
1407 proxy server(s) on different machines, you will need to set a configuration
1408 option to tell Catalyst to read the proxied data from the headers.
1409
1410     MyApp->config->{using_frontend_proxy} = 1;
1411
1412 If you do not wish to use the proxy support at all, you may set:
1413
1414     MyApp->config->{ignore_frontend_proxy} = 1;
1415
1416 =head1 THREAD SAFETY
1417
1418 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
1419 and the standalone forking HTTP server on Windows.  We believe the Catalyst
1420 core to be thread-safe.
1421
1422 If you plan to operate in a threaded environment, remember that all other
1423 modules you are using must also be thread-safe.  Some modules, most notably
1424 DBD::SQLite, are not thread-safe.
1425
1426 =head1 SUPPORT
1427
1428 IRC:
1429
1430     Join #catalyst on irc.perl.org.
1431
1432 Mailing-Lists:
1433
1434     http://lists.rawmode.org/mailman/listinfo/catalyst
1435     http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1436
1437 Web:
1438
1439     http://catalyst.perl.org
1440
1441 =head1 SEE ALSO
1442
1443 =over 4
1444
1445 =item L<Catalyst::Manual> - The Catalyst Manual
1446
1447 =item L<Catalyst::Engine> - Core Engine
1448
1449 =item L<Catalyst::Log> - The Log Class.
1450
1451 =item L<Catalyst::Request> - The Request Object
1452
1453 =item L<Catalyst::Response> - The Response Object
1454
1455 =item L<Catalyst::Test> - The test suite.
1456
1457 =back
1458
1459 =head1 CREDITS
1460
1461 Andy Grundman
1462
1463 Andy Wardley
1464
1465 Andrew Ford
1466
1467 Andrew Ruthven
1468
1469 Arthur Bergman
1470
1471 Autrijus Tang
1472
1473 Christian Hansen
1474
1475 Christopher Hicks
1476
1477 Dan Sully
1478
1479 Danijel Milicevic
1480
1481 David Naughton
1482
1483 Gary Ashton Jones
1484
1485 Geoff Richards
1486
1487 Jesse Sheidlower
1488
1489 Jesse Vincent
1490
1491 Jody Belka
1492
1493 Johan Lindstrom
1494
1495 Juan Camacho
1496
1497 Leon Brocard
1498
1499 Marcus Ramberg
1500
1501 Matt S Trout
1502
1503 Robert Sedlacek
1504
1505 Tatsuhiko Miyagawa
1506
1507 Ulf Edvinsson
1508
1509 Yuval Kogman
1510
1511 =head1 AUTHOR
1512
1513 Sebastian Riedel, C<sri@oook.de>
1514
1515 =head1 LICENSE
1516
1517 This library is free software . You can redistribute it and/or modify it under
1518 the same terms as perl itself.
1519
1520 =cut
1521
1522 1;