lib/Catalyst.pm

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