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 =head1 $c->welcome_message
 520
 521 Returns the Catalyst welcome HTML page.
 522
 523 =cut
 524
 525 sub welcome_message {
 526     my $c    = shift;
 527     my $name = $c->config->{name};
 528     return <<"EOF";
 529 <html>
 530     <head>
 531         <title>$name on Catalyst $VERSION</title>
 532         <style type="text/css">
 533             body {
 534                 text-align: center;
 535                 padding-left: 50%;
 536                 color: #000;
 537                 background-color: #eee;
 538             }
 539             div#content {
 540                 width: 640px;
 541                 margin-left: -320px;
 542                 margin-top: 10px;
 543                 margin-bottom: 10px;
 544                 text-align: left;
 545                 background-color: #ccc;
 546                 border: 1px solid #aaa;
 547                 -moz-border-radius: 10px;
 548             }
 549             p, h1, h2, a {
 550                 margin-left: 20px;
 551                 margin-right: 20px;
 552                 font-family: garamond, verdana, tahoma, sans-serif;
 553             }
 554             div#topbar {
 555                 margin: 0px;
 556             }
 557             div#answers {
 558                 padding: 8px;
 559                 margin: 10px;
 560                 background-color: #eee;
 561                 border: 1px solid #aaa;
 562                 -moz-border-radius: 10px;
 563             }
 564             h1 {
 565                 font-size: 1.2em;
 566                 text-align: center;
 567             }
 568             h2 {
 569                 font-size: 1.0em;
 570             }
 571             p {
 572                 font-size: 0.9em;
 573             }
 574             p.signature {
 575                 text-align: right;
 576                 font-style: italic;
 577             }
 578         </style>
 579     </head>
 580     <body>
 581         <div id="content">
 582             <div id="topbar">
 583                 <h1>$name on Catalyst $VERSION</h1>
 584              </div>
 585              <div id="answers">
 586                  <p>Welcome to the wonderfull world of Catalyst.
 587                     This MVC framework will make webdevelopment
 588                     something you had never expected it to be:
 589                     Fun, rewarding and quick.</p>
 590                  <h2>What to do now?</h2>
 591                  <p>That all depends really, on what <b>you</b> want to do.
 592                     We do, however, provide you with a few starting points.</p>
 593                  <p>If you want to jump right into web development with Catalyst
 594                     you might want to check out the following links.</p>
 595                  <ul>
 596                      <li>
 597                          <a href="http://catalyst.perl.org">
 598                              Catalyst::Manual::Intro
 599                          </a>
 600                      </li>
 601                  </ul>
 602                  <p>If you would like some background information on the
 603                     MVC-pattern, theese links might be able to help you out.</p>
 604                  <ul>
 605                      <li>
 606                          <a href="http://catalyst.perl.org">
 607                              Introduction to Models
 608                          </a>
 609                      </li>
 610                      <li>
 611                          <a href="http://catalyst.perl.org">
 612                              Introduction to Views
 613                          </a>
 614                      </li>
 615                      <li>
 616                          <a href="http://catalyst.perl.org">
 617                              Introduction to Controllers
 618                          </a>
 619                      </li>
 620                  </ul>
 621                  <h2>What to do next?</h2>
 622                  <p>Next you need to create an actuall application. Use the
 623                     helper scripts for what they are worth, they can save you
 624                     alot of work getting everything set up. Also, be sure to
 625                     check out the vast array of plugins for Catalyst.
 626                     They can handle everything from Authentication to Static
 627                     files, and a whole lot in  between.</p>
 628                  <h2>In conclusion</h2>
 629                  <p>The Catalyst team hope you will enjoy Catalyst as much as we                    enjoyed making it, and that rest asure that any and all
 630                     feedback is welcomed</p>
 631                  <p class="signature">-- there is no cabal, 2005</p>
 632              </div>
 633          </div>
 634     </body>
 635 </html>
 636 EOF
 637 }
 638
 639 =back
 640
 641 =head1 INTERNAL METHODS
 642
 643 =over 4
 644
 645 =item $c->benchmark($coderef)
 646
 647 Takes a coderef with arguments and returns elapsed time as float.
 648
 649     my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
 650     $c->log->info( sprintf "Processing took %f seconds", $elapsed );
 651
 652 =cut
 653
 654 sub benchmark {
 655     my $c       = shift;
 656     my $code    = shift;
 657     my $time    = [gettimeofday];
 658     my @return  = &$code(@_);
 659     my $elapsed = tv_interval $time;
 660     return wantarray ? ( $elapsed, @return ) : $elapsed;
 661 }
 662
 663 =item $c->components
 664
 665 Contains the components.
 666
 667 =item $c->counter
 668
 669 Returns a hashref containing coderefs and execution counts.
 670 (Needed for deep recursion detection)
 671
 672 =item $c->depth
 673
 674 Returns the actual forward depth.
 675
 676 =item $c->dispatch
 677
 678 Dispatch request to actions.
 679
 680 =cut
 681
 682 sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
 683
 684 =item $c->execute($class, $coderef)
 685
 686 Execute a coderef in given class and catch exceptions.
 687 Errors are available via $c->error.
 688
 689 =cut
 690
 691 sub execute {
 692     my ( $c, $class, $code ) = @_;
 693     $class = $c->components->{$class} || $class;
 694     $c->state(0);
 695     my $callsub = ( caller(1) )[3];
 696
 697     my $action = '';
 698     if ( $c->debug ) {
 699         $action = "$code";
 700         $action = "/$action" unless $action =~ /\-\>/;
 701         $c->counter->{"$code"}++;
 702
 703         if ( $c->counter->{"$code"} > $RECURSION ) {
 704             my $error = qq/Deep recursion detected in "$action"/;
 705             $c->log->error($error);
 706             $c->error($error);
 707             $c->state(0);
 708             return $c->state;
 709         }
 710
 711         $action = "-> $action" if $callsub =~ /forward$/;
 712     }
 713     $c->{depth}++;
 714     eval {
 715         if ( $c->debug )
 716         {
 717             my ( $elapsed, @state ) =
 718               $c->benchmark( $code, $class, $c, @{ $c->req->args } );
 719             push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
 720             $c->state(@state);
 721         }
 722         else { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }
 723     };
 724     $c->{depth}--;
 725
 726     if ( my $error = $@ ) {
 727
 728         if ( $error eq $DETACH ) { die $DETACH if $c->{depth} > 1 }
 729         else {
 730             unless ( ref $error ) {
 731                 chomp $error;
 732                 $error = qq/Caught exception "$error"/;
 733             }
 734
 735             $c->log->error($error);
 736             $c->error($error);
 737             $c->state(0);
 738         }
 739     }
 740     return $c->state;
 741 }
 742
 743 =item $c->finalize
 744
 745 Finalize request.
 746
 747 =cut
 748
 749 sub finalize {
 750     my $c = shift;
 751
 752     $c->finalize_uploads;
 753
 754     # Error
 755     if ( $#{ $c->error } >= 0 ) {
 756         $c->finalize_error;
 757     }
 758
 759     $c->finalize_headers;
 760
 761     # HEAD request
 762     if ( $c->request->method eq 'HEAD' ) {
 763         $c->response->body('');
 764     }
 765
 766     $c->finalize_body;
 767
 768     return $c->response->status;
 769 }
 770
 771 =item $c->finalize_body
 772
 773 Finalize body.
 774
 775 =cut
 776
 777 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
 778
 779 =item $c->finalize_cookies
 780
 781 Finalize cookies.
 782
 783 =cut
 784
 785 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
 786
 787 =item $c->finalize_error
 788
 789 Finalize error.
 790
 791 =cut
 792
 793 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
 794
 795 =item $c->finalize_headers
 796
 797 Finalize headers.
 798
 799 =cut
 800
 801 sub finalize_headers {
 802     my $c = shift;
 803
 804     # Check if we already finalized headers
 805     return if $c->response->{_finalized_headers};
 806
 807     # Handle redirects
 808     if ( my $location = $c->response->redirect ) {
 809         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
 810         $c->response->header( Location => $location );
 811     }
 812
 813     # Content-Length
 814     if ( $c->response->body && !$c->response->content_length ) {
 815         $c->response->content_length( bytes::length( $c->response->body ) );
 816     }
 817
 818     # Errors
 819     if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
 820         $c->response->headers->remove_header("Content-Length");
 821         $c->response->body('');
 822     }
 823
 824     $c->finalize_cookies;
 825
 826     $c->engine->finalize_headers( $c, @_ );
 827
 828     # Done
 829     $c->response->{_finalized_headers} = 1;
 830 }
 831
 832 =item $c->finalize_output
 833
 834 An alias for finalize_body.
 835
 836 =item $c->finalize_read
 837
 838 Finalize the input after reading is complete.
 839
 840 =cut
 841
 842 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
 843
 844 =item $c->finalize_uploads
 845
 846 Finalize uploads.  Cleans up any temporary files.
 847
 848 =cut
 849
 850 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
 851
 852 =item $c->get_action( $action, $namespace, $inherit )
 853
 854 Get an action in a given namespace.
 855
 856 =cut
 857
 858 sub get_action { my $c = shift; $c->dispatcher->get_action( $c, @_ ) }
 859
 860 =item handle_request( $class, @arguments )
 861
 862 Handles the request.
 863
 864 =cut
 865
 866 sub handle_request {
 867     my ( $class, @arguments ) = @_;
 868
 869     # Always expect worst case!
 870     my $status = -1;
 871     eval {
 872         my @stats = ();
 873
 874         my $handler = sub {
 875             my $c = $class->prepare(@arguments);
 876             $c->{stats} = \@stats;
 877             $c->dispatch;
 878             return $c->finalize;
 879         };
 880
 881         if ( $class->debug ) {
 882             my $elapsed;
 883             ( $elapsed, $status ) = $class->benchmark($handler);
 884             $elapsed = sprintf '%f', $elapsed;
 885             my $av = sprintf '%.3f',
 886               ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
 887             my $t = Text::ASCIITable->new;
 888             $t->setCols( 'Action', 'Time' );
 889             $t->setColWidth( 'Action', 64, 1 );
 890             $t->setColWidth( 'Time',   9,  1 );
 891
 892             for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
 893             $class->log->info(
 894                 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
 895         }
 896         else { $status = &$handler }
 897
 898     };
 899
 900     if ( my $error = $@ ) {
 901         chomp $error;
 902         $class->log->error(qq/Caught exception in engine "$error"/);
 903     }
 904
 905     $COUNT++;
 906     $class->log->_flush() if $class->log->can('_flush');
 907     return $status;
 908 }
 909
 910 =item $c->prepare(@arguments)
 911
 912 Turns the engine-specific request( Apache, CGI ... )
 913 into a Catalyst context .
 914
 915 =cut
 916
 917 sub prepare {
 918     my ( $class, @arguments ) = @_;
 919
 920     my $c = bless {
 921         counter => {},
 922         depth   => 0,
 923         request => Catalyst::Request->new(
 924             {
 925                 arguments        => [],
 926                 body_parameters  => {},
 927                 cookies          => {},
 928                 headers          => HTTP::Headers->new,
 929                 parameters       => {},
 930                 query_parameters => {},
 931                 secure           => 0,
 932                 snippets         => [],
 933                 uploads          => {}
 934             }
 935         ),
 936         response => Catalyst::Response->new(
 937             {
 938                 body    => '',
 939                 cookies => {},
 940                 headers => HTTP::Headers->new(),
 941                 status  => 200
 942             }
 943         ),
 944         stash => {},
 945         state => 0
 946     }, $class;
 947
 948     # For on-demand data
 949     $c->request->{_context}  = $c;
 950     $c->response->{_context} = $c;
 951     weaken( $c->request->{_context} );
 952     weaken( $c->response->{_context} );
 953
 954     if ( $c->debug ) {
 955         my $secs = time - $START || 1;
 956         my $av = sprintf '%.3f', $COUNT / $secs;
 957         $c->log->debug('**********************************');
 958         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 959         $c->log->debug('**********************************');
 960         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 961     }
 962
 963     $c->prepare_request(@arguments);
 964     $c->prepare_connection;
 965     $c->prepare_query_parameters;
 966     $c->prepare_headers;
 967     $c->prepare_cookies;
 968     $c->prepare_path;
 969
 970     # On-demand parsing
 971     $c->prepare_body unless $c->config->{parse_on_demand};
 972
 973     $c->prepare_action;
 974     my $method  = $c->req->method  || '';
 975     my $path    = $c->req->path    || '';
 976     my $address = $c->req->address || '';
 977
 978     $c->log->debug(qq/"$method" request for "$path" from $address/)
 979       if $c->debug;
 980
 981     return $c;
 982 }
 983
 984 =item $c->prepare_action
 985
 986 Prepare action.
 987
 988 =cut
 989
 990 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
 991
 992 =item $c->prepare_body
 993
 994 Prepare message body.
 995
 996 =cut
 997
 998 sub prepare_body {
 999     my $c = shift;
1000
1001     # Do we run for the first time?
1002     return if defined $c->request->{_body};
1003
1004     # Initialize on-demand data
1005     $c->engine->prepare_body( $c, @_ );
1006     $c->prepare_parameters;
1007     $c->prepare_uploads;
1008
1009     if ( $c->debug && keys %{ $c->req->body_parameters } ) {
1010         my $t = Text::ASCIITable->new;
1011         $t->setCols( 'Key', 'Value' );
1012         $t->setColWidth( 'Key',   37, 1 );
1013         $t->setColWidth( 'Value', 36, 1 );
1014         $t->alignCol( 'Value', 'right' );
1015         for my $key ( sort keys %{ $c->req->body_parameters } ) {
1016             my $param = $c->req->body_parameters->{$key};
1017             my $value = defined($param) ? $param : '';
1018             $t->addRow( $key,
1019                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1020         }
1021         $c->log->debug( "Body Parameters are:\n" . $t->draw );
1022     }
1023 }
1024
1025 =item $c->prepare_body_chunk( $chunk )
1026
1027 Prepare a chunk of data before sending it to HTTP::Body.
1028
1029 =cut
1030
1031 sub prepare_body_chunk {
1032     my $c = shift;
1033     $c->engine->prepare_body_chunk( $c, @_ );
1034 }
1035
1036 =item $c->prepare_body_parameters
1037
1038 Prepare body parameters.
1039
1040 =cut
1041
1042 sub prepare_body_parameters {
1043     my $c = shift;
1044     $c->engine->prepare_body_parameters( $c, @_ );
1045 }
1046
1047 =item $c->prepare_connection
1048
1049 Prepare connection.
1050
1051 =cut
1052
1053 sub prepare_connection {
1054     my $c = shift;
1055     $c->engine->prepare_connection( $c, @_ );
1056 }
1057
1058 =item $c->prepare_cookies
1059
1060 Prepare cookies.
1061
1062 =cut
1063
1064 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1065
1066 =item $c->prepare_headers
1067
1068 Prepare headers.
1069
1070 =cut
1071
1072 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1073
1074 =item $c->prepare_parameters
1075
1076 Prepare parameters.
1077
1078 =cut
1079
1080 sub prepare_parameters {
1081     my $c = shift;
1082     $c->prepare_body_parameters;
1083     $c->engine->prepare_parameters( $c, @_ );
1084 }
1085
1086 =item $c->prepare_path
1087
1088 Prepare path and base.
1089
1090 =cut
1091
1092 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1093
1094 =item $c->prepare_query_parameters
1095
1096 Prepare query parameters.
1097
1098 =cut
1099
1100 sub prepare_query_parameters {
1101     my $c = shift;
1102
1103     $c->engine->prepare_query_parameters( $c, @_ );
1104
1105     if ( $c->debug && keys %{ $c->request->query_parameters } ) {
1106         my $t = Text::ASCIITable->new;
1107         $t->setCols( 'Key', 'Value' );
1108         $t->setColWidth( 'Key',   37, 1 );
1109         $t->setColWidth( 'Value', 36, 1 );
1110         $t->alignCol( 'Value', 'right' );
1111         for my $key ( sort keys %{ $c->req->query_parameters } ) {
1112             my $param = $c->req->query_parameters->{$key};
1113             my $value = defined($param) ? $param : '';
1114             $t->addRow( $key,
1115                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1116         }
1117         $c->log->debug( "Query Parameters are:\n" . $t->draw );
1118     }
1119 }
1120
1121 =item $c->prepare_read
1122
1123 Prepare the input for reading.
1124
1125 =cut
1126
1127 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1128
1129 =item $c->prepare_request
1130
1131 Prepare the engine request.
1132
1133 =cut
1134
1135 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1136
1137 =item $c->prepare_uploads
1138
1139 Prepare uploads.
1140
1141 =cut
1142
1143 sub prepare_uploads {
1144     my $c = shift;
1145
1146     $c->engine->prepare_uploads( $c, @_ );
1147
1148     if ( $c->debug && keys %{ $c->request->uploads } ) {
1149         my $t = Text::ASCIITable->new;
1150         $t->setCols( 'Key', 'Filename', 'Type', 'Size' );
1151         $t->setColWidth( 'Key',      12, 1 );
1152         $t->setColWidth( 'Filename', 28, 1 );
1153         $t->setColWidth( 'Type',     18, 1 );
1154         $t->setColWidth( 'Size',     9,  1 );
1155         $t->alignCol( 'Size', 'left' );
1156         for my $key ( sort keys %{ $c->request->uploads } ) {
1157             my $upload = $c->request->uploads->{$key};
1158             for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1159                 $t->addRow( $key, $u->filename, $u->type, $u->size );
1160             }
1161         }
1162         $c->log->debug( "File Uploads are:\n" . $t->draw );
1163     }
1164 }
1165
1166 =item $c->prepare_write
1167
1168 Prepare the output for writing.
1169
1170 =cut
1171
1172 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1173
1174 =item $c->read( [$maxlength] )
1175
1176 Read a chunk of data from the request body.  This method is designed to be
1177 used in a while loop, reading $maxlength bytes on every call.  $maxlength
1178 defaults to the size of the request if not specified.
1179
1180 You have to set MyApp->config->{parse_on_demand} to use this directly.
1181
1182 =cut
1183
1184 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1185
1186 =item $c->run
1187
1188 Starts the engine.
1189
1190 =cut
1191
1192 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1193
1194 =item $c->set_action( $action, $code, $namespace, $attrs )
1195
1196 Set an action in a given namespace.
1197
1198 =cut
1199
1200 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1201
1202 =item $c->setup_actions($component)
1203
1204 Setup actions for a component.
1205
1206 =cut
1207
1208 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1209
1210 =item $c->setup_components
1211
1212 Setup components.
1213
1214 =cut
1215
1216 sub setup_components {
1217     my $class = shift;
1218
1219     my $callback = sub {
1220         my ( $component, $context ) = @_;
1221
1222         unless ( $component->isa('Catalyst::Base') ) {
1223             return $component;
1224         }
1225
1226         my $suffix = Catalyst::Utils::class2classsuffix($component);
1227         my $config = $class->config->{$suffix} || {};
1228
1229         my $instance;
1230
1231         eval { $instance = $component->new( $context, $config ); };
1232
1233         if ( my $error = $@ ) {
1234
1235             chomp $error;
1236
1237             Catalyst::Exception->throw( message =>
1238                   qq/Couldn't instantiate component "$component", "$error"/ );
1239         }
1240
1241         Catalyst::Exception->throw( message =>
1242 qq/Couldn't instantiate component "$component", "new() didn't return a object"/
1243           )
1244           unless ref $instance;
1245         return $instance;
1246     };
1247
1248     eval {
1249         Module::Pluggable::Fast->import(
1250             name   => '_catalyst_components',
1251             search => [
1252                 "$class\::Controller", "$class\::C",
1253                 "$class\::Model",      "$class\::M",
1254                 "$class\::View",       "$class\::V"
1255             ],
1256             callback => $callback
1257         );
1258     };
1259
1260     if ( my $error = $@ ) {
1261
1262         chomp $error;
1263
1264         Catalyst::Exception->throw(
1265             message => qq/Couldn't load components "$error"/ );
1266     }
1267
1268     for my $component ( $class->_catalyst_components($class) ) {
1269         $class->components->{ ref $component || $component } = $component;
1270     }
1271 }
1272
1273 =item $c->setup_dispatcher
1274
1275 =cut
1276
1277 sub setup_dispatcher {
1278     my ( $class, $dispatcher ) = @_;
1279
1280     if ($dispatcher) {
1281         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1282     }
1283
1284     if ( $ENV{CATALYST_DISPATCHER} ) {
1285         $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1286     }
1287
1288     if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1289         $dispatcher =
1290           'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1291     }
1292
1293     unless ($dispatcher) {
1294         $dispatcher = 'Catalyst::Dispatcher';
1295     }
1296
1297     $dispatcher->require;
1298
1299     if ($@) {
1300         Catalyst::Exception->throw(
1301             message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1302     }
1303
1304     # dispatcher instance
1305     $class->dispatcher( $dispatcher->new );
1306 }
1307
1308 =item $c->setup_engine
1309
1310 =cut
1311
1312 sub setup_engine {
1313     my ( $class, $engine ) = @_;
1314
1315     if ($engine) {
1316         $engine = 'Catalyst::Engine::' . $engine;
1317     }
1318
1319     if ( $ENV{CATALYST_ENGINE} ) {
1320         $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1321     }
1322
1323     if ( $ENV{ uc($class) . '_ENGINE' } ) {
1324         $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1325     }
1326
1327     if ( !$engine && $ENV{MOD_PERL} ) {
1328
1329         # create the apache method
1330         {
1331             no strict 'refs';
1332             *{"$class\::apache"} = sub { shift->engine->apache };
1333         }
1334
1335         my ( $software, $version ) =
1336           $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1337
1338         $version =~ s/_//g;
1339         $version =~ s/(\.[^.]+)\./$1/g;
1340
1341         if ( $software eq 'mod_perl' ) {
1342
1343             if ( $version >= 1.99922 ) {
1344                 $engine = 'Catalyst::Engine::Apache2::MP20';
1345             }
1346
1347             elsif ( $version >= 1.9901 ) {
1348                 $engine = 'Catalyst::Engine::Apache2::MP19';
1349             }
1350
1351             elsif ( $version >= 1.24 ) {
1352                 $engine = 'Catalyst::Engine::Apache::MP13';
1353             }
1354
1355             else {
1356                 Catalyst::Exception->throw( message =>
1357                       qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1358             }
1359
1360             # install the correct mod_perl handler
1361             if ( $version >= 1.9901 ) {
1362                 *handler = sub  : method {
1363                     shift->handle_request(@_);
1364                 };
1365             }
1366             else {
1367                 *handler = sub ($$) { shift->handle_request(@_) };
1368             }
1369
1370         }
1371
1372         elsif ( $software eq 'Zeus-Perl' ) {
1373             $engine = 'Catalyst::Engine::Zeus';
1374         }
1375
1376         else {
1377             Catalyst::Exception->throw(
1378                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1379         }
1380     }
1381
1382     unless ($engine) {
1383         $engine = 'Catalyst::Engine::CGI';
1384     }
1385
1386     $engine->require;
1387
1388     if ($@) {
1389         Catalyst::Exception->throw( message =>
1390 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1391         );
1392     }
1393
1394     # engine instance
1395     $class->engine( $engine->new );
1396 }
1397
1398 =item $c->setup_home
1399
1400 =cut
1401
1402 sub setup_home {
1403     my ( $class, $home ) = @_;
1404
1405     if ( $ENV{CATALYST_HOME} ) {
1406         $home = $ENV{CATALYST_HOME};
1407     }
1408
1409     if ( $ENV{ uc($class) . '_HOME' } ) {
1410         $home = $ENV{ uc($class) . '_HOME' };
1411     }
1412
1413     unless ($home) {
1414         $home = Catalyst::Utils::home($class);
1415     }
1416
1417     if ($home) {
1418         $class->config->{home} ||= $home;
1419         $class->config->{root} ||= dir($home)->subdir('root');
1420     }
1421 }
1422
1423 =item $c->setup_log
1424
1425 =cut
1426
1427 sub setup_log {
1428     my ( $class, $debug ) = @_;
1429
1430     unless ( $class->log ) {
1431         $class->log( Catalyst::Log->new );
1432     }
1433
1434     if ( $ENV{CATALYST_DEBUG} || $ENV{ uc($class) . '_DEBUG' } || $debug ) {
1435         no strict 'refs';
1436         *{"$class\::debug"} = sub { 1 };
1437         $class->log->debug('Debug messages enabled');
1438     }
1439 }
1440
1441 =item $c->setup_plugins
1442
1443 =cut
1444
1445 sub setup_plugins {
1446     my ( $class, $plugins ) = @_;
1447
1448     $plugins ||= [];
1449     for my $plugin ( reverse @$plugins ) {
1450
1451         $plugin = "Catalyst::Plugin::$plugin";
1452
1453         $plugin->require;
1454
1455         if ($@) {
1456             Catalyst::Exception->throw(
1457                 message => qq/Couldn't load plugin "$plugin", "$@"/ );
1458         }
1459
1460         {
1461             no strict 'refs';
1462             unshift @{"$class\::ISA"}, $plugin;
1463         }
1464     }
1465 }
1466
1467 =item $c->write( $data )
1468
1469 Writes $data to the output stream.  When using this method directly, you will
1470 need to manually set the Content-Length header to the length of your output
1471 data, if known.
1472
1473 =cut
1474
1475 sub write {
1476     my $c = shift;
1477
1478     # Finalize headers if someone manually writes output
1479     $c->finalize_headers;
1480
1481     return $c->engine->write( $c, @_ );
1482 }
1483
1484 =back
1485
1486 =head1 CASE SENSITIVITY
1487
1488 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> becomes
1489 C</foo/bar>.
1490
1491 But you can activate case sensitivity with a config parameter.
1492
1493     MyApp->config->{case_sensitive} = 1;
1494
1495 So C<MyApp::C::Foo::Bar> becomes C</Foo/Bar>.
1496
1497 =head1 ON-DEMAND PARSER
1498
1499 The request body is usually parsed at the beginning of a request,
1500 but if you want to handle input yourself or speed things up a bit
1501 you can enable on-demand parsing with a config parameter.
1502
1503     MyApp->config->{parse_on_demand} = 1;
1504
1505 =head1 PROXY SUPPORT
1506
1507 Many production servers operate using the common double-server approach, with
1508 a lightweight frontend web server passing requests to a larger backend
1509 server.  An application running on the backend server must deal with two
1510 problems: the remote user always appears to be '127.0.0.1' and the server's
1511 hostname will appear to be 'localhost' regardless of the virtual host the
1512 user connected through.
1513
1514 Catalyst will automatically detect this situation when you are running both
1515 the frontend and backend servers on the same machine.  The following changes
1516 are made to the request.
1517
1518     $c->req->address is set to the user's real IP address, as read from the
1519     HTTP_X_FORWARDED_FOR header.
1520
1521     The host value for $c->req->base and $c->req->uri is set to the real host,
1522     as read from the HTTP_X_FORWARDED_HOST header.
1523
1524 Obviously, your web server must support these 2 headers for this to work.
1525
1526 In a more complex server farm environment where you may have your frontend
1527 proxy server(s) on different machines, you will need to set a configuration
1528 option to tell Catalyst to read the proxied data from the headers.
1529
1530     MyApp->config->{using_frontend_proxy} = 1;
1531
1532 If you do not wish to use the proxy support at all, you may set:
1533
1534     MyApp->config->{ignore_frontend_proxy} = 1;
1535
1536 =head1 THREAD SAFETY
1537
1538 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
1539 and the standalone forking HTTP server on Windows.  We believe the Catalyst
1540 core to be thread-safe.
1541
1542 If you plan to operate in a threaded environment, remember that all other
1543 modules you are using must also be thread-safe.  Some modules, most notably
1544 DBD::SQLite, are not thread-safe.
1545
1546 =head1 SUPPORT
1547
1548 IRC:
1549
1550     Join #catalyst on irc.perl.org.
1551
1552 Mailing-Lists:
1553
1554     http://lists.rawmode.org/mailman/listinfo/catalyst
1555     http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1556
1557 Web:
1558
1559     http://catalyst.perl.org
1560
1561 =head1 SEE ALSO
1562
1563 =over 4
1564
1565 =item L<Catalyst::Manual> - The Catalyst Manual
1566
1567 =item L<Catalyst::Engine> - Core Engine
1568
1569 =item L<Catalyst::Log> - The Log Class.
1570
1571 =item L<Catalyst::Request> - The Request Object
1572
1573 =item L<Catalyst::Response> - The Response Object
1574
1575 =item L<Catalyst::Test> - The test suite.
1576
1577 =back
1578
1579 =head1 CREDITS
1580
1581 Andy Grundman
1582
1583 Andy Wardley
1584
1585 Andrew Ford
1586
1587 Andrew Ruthven
1588
1589 Arthur Bergman
1590
1591 Autrijus Tang
1592
1593 Christian Hansen
1594
1595 Christopher Hicks
1596
1597 Dan Sully
1598
1599 Danijel Milicevic
1600
1601 David Naughton
1602
1603 Gary Ashton Jones
1604
1605 Geoff Richards
1606
1607 Jesse Sheidlower
1608
1609 Jesse Vincent
1610
1611 Jody Belka
1612
1613 Johan Lindstrom
1614
1615 Juan Camacho
1616
1617 Leon Brocard
1618
1619 Marcus Ramberg
1620
1621 Matt S Trout
1622
1623 Robert Sedlacek
1624
1625 Tatsuhiko Miyagawa
1626
1627 Ulf Edvinsson
1628
1629 Yuval Kogman
1630
1631 =head1 AUTHOR
1632
1633 Sebastian Riedel, C<sri@oook.de>
1634
1635 =head1 LICENSE
1636
1637 This library is free software . You can redistribute it and/or modify it under
1638 the same terms as perl itself.
1639
1640 =cut
1641
1642 1;