lib/Catalyst.pm

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