lib/Catalyst.pm

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