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 = 6;
  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( 'Filename', 'Type', 'Size' );
1031         $t->setColWidth( 'Filename', 37, 1 );
1032         $t->setColWidth( 'Type',     24, 1 );
1033         $t->setColWidth( 'Size',     9,  1 );
1034         $t->alignCol( 'Size', 'left' );
1035         for my $key ( sort keys %{ $c->request->uploads } ) {
1036             my $upload = $c->request->uploads->{$key};
1037             for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1038                 $t->addRow( $key, $u->type, $u->size );
1039             }
1040         }
1041         $c->log->debug( "File Uploads are:\n" . $t->draw );
1042     }
1043 }
1044
1045 =item $c->prepare_write
1046
1047 Prepare the output for writing.
1048
1049 =cut
1050
1051 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1052
1053 =item $c->read( [$maxlength] )
1054
1055 Read a chunk of data from the request body.  This method is designed to be
1056 used in a while loop, reading $maxlength bytes on every call.  $maxlength
1057 defaults to the size of the request if not specified.
1058
1059 You have to set MyApp->config->{parse_on_demand} to use this directly.
1060
1061 =cut
1062
1063 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1064
1065 =item $c->run
1066
1067 Starts the engine.
1068
1069 =cut
1070
1071 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1072
1073 =item $c->set_action( $action, $code, $namespace, $attrs )
1074
1075 Set an action in a given namespace.
1076
1077 =cut
1078
1079 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1080
1081 =item $c->setup_actions($component)
1082
1083 Setup actions for a component.
1084
1085 =cut
1086
1087 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1088
1089 =item $c->setup_components
1090
1091 Setup components.
1092
1093 =cut
1094
1095 sub setup_components {
1096     my $class = shift;
1097
1098     my $callback = sub {
1099         my ( $component, $context ) = @_;
1100
1101         unless ( $component->isa('Catalyst::Base') ) {
1102             return $component;
1103         }
1104
1105         my $suffix = Catalyst::Utils::class2classsuffix($component);
1106         my $config = $class->config->{$suffix} || {};
1107
1108         my $instance;
1109
1110         eval { $instance = $component->new( $context, $config ); };
1111
1112         if ( my $error = $@ ) {
1113
1114             chomp $error;
1115
1116             Catalyst::Exception->throw( message =>
1117                   qq/Couldn't instantiate component "$component", "$error"/ );
1118         }
1119
1120         Catalyst::Exception->throw( message =>
1121 qq/Couldn't instantiate component "$component", "new() didn't return a object"/
1122           )
1123           unless ref $instance;
1124         return $instance;
1125     };
1126
1127     eval {
1128         Module::Pluggable::Fast->import(
1129             name   => '_catalyst_components',
1130             search => [
1131                 "$class\::Controller", "$class\::C",
1132                 "$class\::Model",      "$class\::M",
1133                 "$class\::View",       "$class\::V"
1134             ],
1135             callback => $callback
1136         );
1137     };
1138
1139     if ( my $error = $@ ) {
1140
1141         chomp $error;
1142
1143         Catalyst::Exception->throw(
1144             message => qq/Couldn't load components "$error"/ );
1145     }
1146
1147     for my $component ( $class->_catalyst_components($class) ) {
1148         $class->components->{ ref $component || $component } = $component;
1149     }
1150 }
1151
1152 =item $c->setup_dispatcher
1153
1154 =cut
1155
1156 sub setup_dispatcher {
1157     my ( $class, $dispatcher ) = @_;
1158
1159     if ($dispatcher) {
1160         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1161     }
1162
1163     if ( $ENV{CATALYST_DISPATCHER} ) {
1164         $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1165     }
1166
1167     if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1168         $dispatcher =
1169           'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1170     }
1171
1172     unless ($dispatcher) {
1173         $dispatcher = 'Catalyst::Dispatcher';
1174     }
1175
1176     $dispatcher->require;
1177
1178     if ($@) {
1179         Catalyst::Exception->throw(
1180             message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1181     }
1182
1183     # dispatcher instance
1184     $class->dispatcher( $dispatcher->new );
1185 }
1186
1187 =item $c->setup_engine
1188
1189 =cut
1190
1191 sub setup_engine {
1192     my ( $class, $engine ) = @_;
1193
1194     if ($engine) {
1195         $engine = 'Catalyst::Engine::' . $engine;
1196     }
1197
1198     if ( $ENV{CATALYST_ENGINE} ) {
1199         $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1200     }
1201
1202     if ( $ENV{ uc($class) . '_ENGINE' } ) {
1203         $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1204     }
1205
1206     if ( !$engine && $ENV{MOD_PERL} ) {
1207
1208         # create the apache method
1209         {
1210             no strict 'refs';
1211             *{"$class\::apache"} = sub { shift->engine->apache };
1212         }
1213
1214         my ( $software, $version ) =
1215           $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1216
1217         $version =~ s/_//g;
1218         $version =~ s/(\.[^.]+)\./$1/g;
1219
1220         if ( $software eq 'mod_perl' ) {
1221
1222             if ( $version >= 1.99922 ) {
1223                 $engine = 'Catalyst::Engine::Apache2::MP20';
1224             }
1225
1226             elsif ( $version >= 1.9901 ) {
1227                 $engine = 'Catalyst::Engine::Apache2::MP19';
1228             }
1229
1230             elsif ( $version >= 1.24 ) {
1231                 $engine = 'Catalyst::Engine::Apache::MP13';
1232             }
1233
1234             else {
1235                 Catalyst::Exception->throw( message =>
1236                       qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1237             }
1238
1239             # install the correct mod_perl handler
1240             if ( $version >= 1.9901 ) {
1241                 *handler = sub  : method {
1242                     shift->handle_request(@_);
1243                 };
1244             }
1245             else {
1246                 *handler = sub ($$) { shift->handle_request(@_) };
1247             }
1248
1249         }
1250
1251         elsif ( $software eq 'Zeus-Perl' ) {
1252             $engine = 'Catalyst::Engine::Zeus';
1253         }
1254
1255         else {
1256             Catalyst::Exception->throw(
1257                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1258         }
1259     }
1260
1261     unless ($engine) {
1262         $engine = 'Catalyst::Engine::CGI';
1263     }
1264
1265     $engine->require;
1266
1267     if ($@) {
1268         Catalyst::Exception->throw( message =>
1269 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1270         );
1271     }
1272
1273     # engine instance
1274     $class->engine( $engine->new );
1275 }
1276
1277 =item $c->setup_home
1278
1279 =cut
1280
1281 sub setup_home {
1282     my ( $class, $home ) = @_;
1283
1284     if ( $ENV{CATALYST_HOME} ) {
1285         $home = $ENV{CATALYST_HOME};
1286     }
1287
1288     if ( $ENV{ uc($class) . '_HOME' } ) {
1289         $home = $ENV{ uc($class) . '_HOME' };
1290     }
1291
1292     unless ($home) {
1293         $home = Catalyst::Utils::home($class);
1294     }
1295
1296     if ($home) {
1297         $class->config->{home} ||= $home;
1298         $class->config->{root} ||= dir($home)->subdir('root');
1299     }
1300 }
1301
1302 =item $c->setup_log
1303
1304 =cut
1305
1306 sub setup_log {
1307     my ( $class, $debug ) = @_;
1308
1309     unless ( $class->log ) {
1310         $class->log( Catalyst::Log->new );
1311     }
1312
1313     if ( $ENV{CATALYST_DEBUG} || $ENV{ uc($class) . '_DEBUG' } || $debug ) {
1314         no strict 'refs';
1315         *{"$class\::debug"} = sub { 1 };
1316         $class->log->debug('Debug messages enabled');
1317     }
1318 }
1319
1320 =item $c->setup_plugins
1321
1322 =cut
1323
1324 sub setup_plugins {
1325     my ( $class, $plugins ) = @_;
1326
1327     $plugins ||= [];
1328     for my $plugin ( reverse @$plugins ) {
1329
1330         $plugin = "Catalyst::Plugin::$plugin";
1331
1332         $plugin->require;
1333
1334         if ($@) {
1335             Catalyst::Exception->throw(
1336                 message => qq/Couldn't load plugin "$plugin", "$@"/ );
1337         }
1338
1339         {
1340             no strict 'refs';
1341             unshift @{"$class\::ISA"}, $plugin;
1342         }
1343     }
1344 }
1345
1346 =item $c->write( $data )
1347
1348 Writes $data to the output stream.  When using this method directly, you will
1349 need to manually set the Content-Length header to the length of your output
1350 data, if known.
1351
1352 =cut
1353
1354 sub write {
1355     my $c = shift;
1356
1357     # Finalize headers if someone manually writes output
1358     $c->finalize_headers;
1359
1360     return $c->engine->write( $c, @_ );
1361 }
1362
1363 =back
1364
1365 =head1 CASE SENSITIVITY
1366
1367 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> becomes
1368 C</foo/bar>.
1369
1370 But you can activate case sensitivity with a config parameter.
1371
1372     MyApp->config->{case_sensitive} = 1;
1373
1374 So C<MyApp::C::Foo::Bar> becomes C</Foo/Bar>.
1375
1376 =head1 ON-DEMAND PARSER
1377
1378 The request body is usually parsed at the beginning of a request,
1379 but if you want to handle input yourself or speed things up a bit
1380 you can enable on-demand parsing with a config parameter.
1381
1382     MyApp->config->{parse_on_demand} = 1;
1383
1384 =head1 PROXY SUPPORT
1385
1386 Many production servers operate using the common double-server approach, with
1387 a lightweight frontend web server passing requests to a larger backend
1388 server.  An application running on the backend server must deal with two
1389 problems: the remote user always appears to be '127.0.0.1' and the server's
1390 hostname will appear to be 'localhost' regardless of the virtual host the
1391 user connected through.
1392
1393 Catalyst will automatically detect this situation when you are running both
1394 the frontend and backend servers on the same machine.  The following changes
1395 are made to the request.
1396
1397     $c->req->address is set to the user's real IP address, as read from the
1398     HTTP_X_FORWARDED_FOR header.
1399
1400     The host value for $c->req->base and $c->req->uri is set to the real host,
1401     as read from the HTTP_X_FORWARDED_HOST header.
1402
1403 Obviously, your web server must support these 2 headers for this to work.
1404
1405 In a more complex server farm environment where you may have your frontend
1406 proxy server(s) on different machines, you will need to set a configuration
1407 option to tell Catalyst to read the proxied data from the headers.
1408
1409     MyApp->config->{using_frontend_proxy} = 1;
1410
1411 If you do not wish to use the proxy support at all, you may set:
1412
1413     MyApp->config->{ignore_frontend_proxy} = 1;
1414
1415 =head1 THREAD SAFETY
1416
1417 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
1418 and the standalone forking HTTP server on Windows.  We believe the Catalyst
1419 core to be thread-safe.
1420
1421 If you plan to operate in a threaded environment, remember that all other
1422 modules you are using must also be thread-safe.  Some modules, most notably
1423 DBD::SQLite, are not thread-safe.
1424
1425 =head1 SUPPORT
1426
1427 IRC:
1428
1429     Join #catalyst on irc.perl.org.
1430
1431 Mailing-Lists:
1432
1433     http://lists.rawmode.org/mailman/listinfo/catalyst
1434     http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1435
1436 Web:
1437
1438     http://catalyst.perl.org
1439
1440 =head1 SEE ALSO
1441
1442 =over 4
1443
1444 =item L<Catalyst::Manual> - The Catalyst Manual
1445
1446 =item L<Catalyst::Engine> - Core Engine
1447
1448 =item L<Catalyst::Log> - The Log Class.
1449
1450 =item L<Catalyst::Request> - The Request Object
1451
1452 =item L<Catalyst::Response> - The Response Object
1453
1454 =item L<Catalyst::Test> - The test suite.
1455
1456 =back
1457
1458 =head1 CREDITS
1459
1460 Andy Grundman
1461
1462 Andy Wardley
1463
1464 Andrew Ford
1465
1466 Andrew Ruthven
1467
1468 Arthur Bergman
1469
1470 Autrijus Tang
1471
1472 Christian Hansen
1473
1474 Christopher Hicks
1475
1476 Dan Sully
1477
1478 Danijel Milicevic
1479
1480 David Naughton
1481
1482 Gary Ashton Jones
1483
1484 Geoff Richards
1485
1486 Jesse Sheidlower
1487
1488 Jesse Vincent
1489
1490 Jody Belka
1491
1492 Johan Lindstrom
1493
1494 Juan Camacho
1495
1496 Leon Brocard
1497
1498 Marcus Ramberg
1499
1500 Matt S Trout
1501
1502 Robert Sedlacek
1503
1504 Tatsuhiko Miyagawa
1505
1506 Ulf Edvinsson
1507
1508 Yuval Kogman
1509
1510 =head1 AUTHOR
1511
1512 Sebastian Riedel, C<sri@oook.de>
1513
1514 =head1 LICENSE
1515
1516 This library is free software . You can redistribute it and/or modify it under
1517 the same terms as perl itself.
1518
1519 =cut
1520
1521 1;