lib/Catalyst/Engine.pm

   1 package Catalyst::Engine;
   2
   3 use strict;
   4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
   5 use attributes ();
   6 use UNIVERSAL::require;
   7 use CGI::Cookie;
   8 use Data::Dumper;
   9 use HTML::Entities;
  10 use HTTP::Headers;
  11 use Time::HiRes qw/gettimeofday tv_interval/;
  12 use Text::ASCIITable;
  13 use Catalyst::Request;
  14 use Catalyst::Request::Upload;
  15 use Catalyst::Response;
  16 use Catalyst::Utils;
  17
  18 require Module::Pluggable::Fast;
  19
  20 # For pretty dumps
  21 $Data::Dumper::Terse = 1;
  22
  23 __PACKAGE__->mk_classdata('components');
  24 __PACKAGE__->mk_accessors(qw/counter request response state/);
  25
  26 *comp = \&component;
  27 *req  = \&request;
  28 *res  = \&response;
  29
  30 # For backwards compatibility
  31 *finalize_output = \&finalize_body;
  32
  33 # For statistics
  34 our $COUNT     = 1;
  35 our $START     = time;
  36 our $RECURSION = 1000;
  37
  38 =head1 NAME
  39
  40 Catalyst::Engine - The Catalyst Engine
  41
  42 =head1 SYNOPSIS
  43
  44 See L<Catalyst>.
  45
  46 =head1 DESCRIPTION
  47
  48 =head1 METHODS
  49
  50 =over 4
  51
  52 =item $c->benchmark($coderef)
  53
  54 Takes a coderef with arguments and returns elapsed time as float.
  55
  56     my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
  57     $c->log->info( sprintf "Processing took %f seconds", $elapsed );
  58
  59 =cut
  60
  61 sub benchmark {
  62     my $c       = shift;
  63     my $code    = shift;
  64     my $time    = [gettimeofday];
  65     my @return  = &$code(@_);
  66     my $elapsed = tv_interval $time;
  67     return wantarray ? ( $elapsed, @return ) : $elapsed;
  68 }
  69
  70 =item $c->comp($name)
  71
  72 =item $c->component($name)
  73
  74 Get a component object by name.
  75
  76     $c->comp('MyApp::Model::MyModel')->do_stuff;
  77
  78 Regex search for a component.
  79
  80     $c->comp('mymodel')->do_stuff;
  81
  82 =cut
  83
  84 sub component {
  85     my $c = shift;
  86
  87     if (@_) {
  88
  89         my $name = shift;
  90
  91         if ( my $component = $c->components->{$name} ) {
  92             return $component;
  93         }
  94
  95         else {
  96             for my $component ( keys %{ $c->components } ) {
  97                 return $c->components->{$component} if $component =~ /$name/i;
  98             }
  99         }
 100     }
 101
 102     return sort keys %{ $c->components };
 103 }
 104
 105 =item $c->counter
 106
 107 Returns a hashref containing coderefs and execution counts.
 108 (Needed for deep recursion detection)
 109
 110 =item $c->error
 111
 112 =item $c->error($error, ...)
 113
 114 =item $c->error($arrayref)
 115
 116 Returns an arrayref containing error messages.
 117
 118     my @error = @{ $c->error };
 119
 120 Add a new error.
 121
 122     $c->error('Something bad happened');
 123
 124 =cut
 125
 126 sub error {
 127     my $c = shift;
 128     my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
 129     push @{ $c->{error} }, @$error;
 130     return $c->{error};
 131 }
 132
 133 =item $c->execute($class, $coderef)
 134
 135 Execute a coderef in given class and catch exceptions.
 136 Errors are available via $c->error.
 137
 138 =cut
 139
 140 sub execute {
 141     my ( $c, $class, $code ) = @_;
 142     $class = $c->components->{$class} || $class;
 143     $c->state(0);
 144     my $callsub = ( caller(1) )[3];
 145
 146     my $action = '';
 147     if ( $c->debug ) {
 148         $action = $c->actions->{reverse}->{"$code"};
 149         $action = "/$action" unless $action =~ /\-\>/;
 150         $c->counter->{"$code"}++;
 151
 152         if ( $c->counter->{"$code"} > $RECURSION ) {
 153             my $error = qq/Deep recursion detected in "$action"/;
 154             $c->log->error($error);
 155             $c->error($error);
 156             $c->state(0);
 157             return $c->state;
 158         }
 159
 160         $action = "-> $action" if $callsub =~ /forward$/;
 161     }
 162
 163     eval {
 164         if ( $c->debug )
 165         {
 166             my ( $elapsed, @state ) = $c->benchmark( $code, $class, $c, @{ $c->req->args } );
 167             push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
 168             $c->state(@state);
 169         }
 170         else { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }
 171     };
 172
 173     if ( my $error = $@ ) {
 174
 175         unless ( ref $error ) {
 176             chomp $error;
 177             $error = qq/Caught exception "$error"/;
 178         }
 179
 180         $c->log->error($error);
 181         $c->error($error);
 182         $c->state(0);
 183     }
 184     return $c->state;
 185 }
 186
 187 =item $c->finalize
 188
 189 Finalize request.
 190
 191 =cut
 192
 193 sub finalize {
 194     my $c = shift;
 195
 196     $c->finalize_cookies;
 197
 198     if ( my $location = $c->response->redirect ) {
 199         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
 200         $c->response->header( Location => $location );
 201         $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
 202     }
 203
 204     if ( $#{ $c->error } >= 0 ) {
 205         $c->finalize_error;
 206     }
 207
 208     if ( !$c->response->body && $c->response->status !~ /^(1|3)\d\d$/ ) {
 209         $c->finalize_error;
 210     }
 211
 212     if ( $c->response->body && !$c->response->content_length ) {
 213         use bytes;    # play safe with a utf8 aware perl
 214         $c->response->content_length( length $c->response->body );
 215     }
 216
 217     my $status = $c->finalize_headers;
 218     $c->finalize_body;
 219     return $status;
 220 }
 221
 222 =item $c->finalize_output
 223
 224 <obsolete>, see finalize_body
 225
 226 =item $c->finalize_body
 227
 228 Finalize body.
 229
 230 =cut
 231
 232 sub finalize_body { }
 233
 234 =item $c->finalize_cookies
 235
 236 Finalize cookies.
 237
 238 =cut
 239
 240 sub finalize_cookies {
 241     my $c = shift;
 242
 243     while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
 244         my $cookie = CGI::Cookie->new(
 245             -name    => $name,
 246             -value   => $cookie->{value},
 247             -expires => $cookie->{expires},
 248             -domain  => $cookie->{domain},
 249             -path    => $cookie->{path},
 250             -secure  => $cookie->{secure} || 0
 251         );
 252
 253         $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
 254     }
 255 }
 256
 257 =item $c->finalize_error
 258
 259 Finalize error.
 260
 261 =cut
 262
 263 sub finalize_error {
 264     my $c = shift;
 265
 266     $c->res->headers->content_type('text/html');
 267     my $name = $c->config->{name} || 'Catalyst Application';
 268
 269     my ( $title, $error, $infos );
 270     if ( $c->debug ) {
 271         $error = join '<br/>', @{ $c->error };
 272         $error ||= 'No output';
 273         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 274         my $req   = encode_entities Dumper $c->req;
 275         my $res   = encode_entities Dumper $c->res;
 276         my $stash = encode_entities Dumper $c->stash;
 277         $infos = <<"";
 278 <br/>
 279 <b><u>Request</u></b><br/>
 280 <pre>$req</pre>
 281 <b><u>Response</u></b><br/>
 282 <pre>$res</pre>
 283 <b><u>Stash</u></b><br/>
 284 <pre>$stash</pre>
 285
 286     }
 287     else {
 288         $title = $name;
 289         $error = '';
 290         $infos = <<"";
 291 <pre>
 292 (en) Please come back later
 293 (de) Bitte versuchen sie es spaeter nocheinmal
 294 (nl) Gelieve te komen later terug
 295 (no) Vennligst prov igjen senere
 296 (fr) Veuillez revenir plus tard
 297 (es) Vuelto por favor mas adelante
 298 (pt) Voltado por favor mais tarde
 299 (it) Ritornato prego più successivamente
 300 </pre>
 301
 302         $name = '';
 303     }
 304     $c->res->body( <<"" );
 305 <html>
 306 <head>
 307     <title>$title</title>
 308     <style type="text/css">
 309         body {
 310             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 311                          Tahoma, Arial, helvetica, sans-serif;
 312             color: #ddd;
 313             background-color: #eee;
 314             margin: 0px;
 315             padding: 0px;
 316         }
 317         div.box {
 318             background-color: #ccc;
 319             border: 1px solid #aaa;
 320             padding: 4px;
 321             margin: 10px;
 322             -moz-border-radius: 10px;
 323         }
 324         div.error {
 325             background-color: #977;
 326             border: 1px solid #755;
 327             padding: 8px;
 328             margin: 4px;
 329             margin-bottom: 10px;
 330             -moz-border-radius: 10px;
 331         }
 332         div.infos {
 333             background-color: #797;
 334             border: 1px solid #575;
 335             padding: 8px;
 336             margin: 4px;
 337             margin-bottom: 10px;
 338             -moz-border-radius: 10px;
 339         }
 340         div.name {
 341             background-color: #779;
 342             border: 1px solid #557;
 343             padding: 8px;
 344             margin: 4px;
 345             -moz-border-radius: 10px;
 346         }
 347     </style>
 348 </head>
 349 <body>
 350     <div class="box">
 351         <div class="error">$error</div>
 352         <div class="infos">$infos</div>
 353         <div class="name">$name</div>
 354     </div>
 355 </body>
 356 </html>
 357
 358 }
 359
 360 =item $c->finalize_headers
 361
 362 Finalize headers.
 363
 364 =cut
 365
 366 sub finalize_headers { }
 367
 368 =item $c->handler( $class, @arguments )
 369
 370 Handles the request.
 371
 372 =cut
 373
 374 sub handler {
 375     my ( $class, @arguments ) = @_;
 376
 377     # Always expect worst case!
 378     my $status = -1;
 379     eval {
 380         my @stats = ();
 381
 382         my $handler = sub {
 383             my $c = $class->prepare(@arguments);
 384             $c->{stats} = \@stats;
 385             $c->dispatch;
 386             return $c->finalize;
 387         };
 388
 389         if ( $class->debug ) {
 390             my $elapsed;
 391             ( $elapsed, $status ) = $class->benchmark($handler);
 392             $elapsed = sprintf '%f', $elapsed;
 393             my $av = sprintf '%.3f',
 394               ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
 395             my $t = Text::ASCIITable->new;
 396             $t->setCols( 'Action', 'Time' );
 397             $t->setColWidth( 'Action', 64, 1 );
 398             $t->setColWidth( 'Time',   9,  1 );
 399
 400             for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
 401             $class->log->info( "Request took $elapsed" . "s ($av/s)",
 402                 $t->draw );
 403         }
 404         else { $status = &$handler }
 405
 406     };
 407
 408     if ( my $error = $@ ) {
 409         chomp $error;
 410         $class->log->error(qq/Caught exception in engine "$error"/);
 411     }
 412
 413     $COUNT++;
 414     return $status;
 415 }
 416
 417 =item $c->prepare(@arguments)
 418
 419 Turns the engine-specific request( Apache, CGI ... )
 420 into a Catalyst context .
 421
 422 =cut
 423
 424 sub prepare {
 425     my ( $class, @arguments ) = @_;
 426
 427     my $c = bless {
 428         counter => {},
 429         request => Catalyst::Request->new(
 430             {
 431                 arguments  => [],
 432                 cookies    => {},
 433                 headers    => HTTP::Headers->new,
 434                 parameters => {},
 435                 secure     => 0,
 436                 snippets   => [],
 437                 uploads    => {}
 438             }
 439         ),
 440         response => Catalyst::Response->new(
 441             {
 442                 body    => '',
 443                 cookies => {},
 444                 headers => HTTP::Headers->new,
 445                 status  => 200
 446             }
 447         ),
 448         stash => {},
 449         state => 0
 450     }, $class;
 451
 452     if ( $c->debug ) {
 453         my $secs = time - $START || 1;
 454         my $av = sprintf '%.3f', $COUNT / $secs;
 455         $c->log->debug('**********************************');
 456         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 457         $c->log->debug('**********************************');
 458         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 459     }
 460
 461     $c->prepare_request(@arguments);
 462     $c->prepare_connection;
 463     $c->prepare_headers;
 464     $c->prepare_cookies;
 465     $c->prepare_path;
 466     $c->prepare_action;
 467
 468     my $method   = $c->req->method   || '';
 469     my $path     = $c->req->path     || '';
 470     my $address  = $c->req->address  || '';
 471
 472     $c->log->debug(qq/"$method" request for "$path" from $address/)
 473       if $c->debug;
 474
 475     if ( $c->request->method eq 'POST' and $c->request->content_length ) {
 476
 477         if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
 478             $c->prepare_parameters;
 479         }
 480         elsif ( $c->req->content_type eq 'multipart/form-data' ) {
 481             $c->prepare_parameters;
 482             $c->prepare_uploads;
 483         }
 484         else {
 485             $c->prepare_body;
 486         }
 487     }
 488
 489     if ( $c->request->method eq 'GET' ) {
 490         $c->prepare_parameters;
 491     }
 492
 493     if ( $c->debug && keys %{ $c->req->params } ) {
 494         my $t = Text::ASCIITable->new;
 495         $t->setCols( 'Key', 'Value' );
 496         $t->setColWidth( 'Key',   37, 1 );
 497         $t->setColWidth( 'Value', 36, 1 );
 498         for my $key ( sort keys %{ $c->req->params } ) {
 499             my $param = $c->req->params->{$key};
 500             my $value = defined($param) ? $param : '';
 501             $t->addRow( $key, $value );
 502         }
 503         $c->log->debug( 'Parameters are', $t->draw );
 504     }
 505
 506     return $c;
 507 }
 508
 509 =item $c->prepare_action
 510
 511 Prepare action.
 512
 513 =cut
 514
 515 sub prepare_action {
 516     my $c    = shift;
 517     my $path = $c->req->path;
 518     my @path = split /\//, $c->req->path;
 519     $c->req->args( \my @args );
 520
 521     while (@path) {
 522         $path = join '/', @path;
 523         if ( my $result = ${ $c->get_action($path) }[0] ) {
 524
 525             # It's a regex
 526             if ($#$result) {
 527                 my $match    = $result->[1];
 528                 my @snippets = @{ $result->[2] };
 529                 $c->log->debug(
 530                     qq/Requested action is "$path" and matched "$match"/)
 531                   if $c->debug;
 532                 $c->log->debug(
 533                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 534                   if ( $c->debug && @snippets );
 535                 $c->req->action($match);
 536                 $c->req->snippets( \@snippets );
 537             }
 538
 539             else {
 540                 $c->req->action($path);
 541                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 542             }
 543
 544             $c->req->match($path);
 545             last;
 546         }
 547         unshift @args, pop @path;
 548     }
 549
 550     unless ( $c->req->action ) {
 551         $c->req->action('default');
 552         $c->req->match('');
 553     }
 554
 555     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 556       if ( $c->debug && @args );
 557 }
 558
 559 =item $c->prepare_body
 560
 561 Prepare message body.
 562
 563 =cut
 564
 565 sub prepare_body { }
 566
 567 =item $c->prepare_connection
 568
 569 Prepare connection.
 570
 571 =cut
 572
 573 sub prepare_connection { }
 574
 575 =item $c->prepare_cookies
 576
 577 Prepare cookies.
 578
 579 =cut
 580
 581 sub prepare_cookies {
 582     my $c = shift;
 583
 584     if ( my $header = $c->request->header('Cookie') ) {
 585         $c->req->cookies( { CGI::Cookie->parse($header) } );
 586     }
 587 }
 588
 589 =item $c->prepare_headers
 590
 591 Prepare headers.
 592
 593 =cut
 594
 595 sub prepare_headers { }
 596
 597 =item $c->prepare_parameters
 598
 599 Prepare parameters.
 600
 601 =cut
 602
 603 sub prepare_parameters { }
 604
 605 =item $c->prepare_path
 606
 607 Prepare path and base.
 608
 609 =cut
 610
 611 sub prepare_path { }
 612
 613 =item $c->prepare_request
 614
 615 Prepare the engine request.
 616
 617 =cut
 618
 619 sub prepare_request { }
 620
 621 =item $c->prepare_uploads
 622
 623 Prepare uploads.
 624
 625 =cut
 626
 627 sub prepare_uploads { }
 628
 629 =item $c->run
 630
 631 Starts the engine.
 632
 633 =cut
 634
 635 sub run { }
 636
 637 =item $c->request
 638
 639 =item $c->req
 640
 641 Returns a C<Catalyst::Request> object.
 642
 643     my $req = $c->req;
 644
 645 =item $c->response
 646
 647 =item $c->res
 648
 649 Returns a C<Catalyst::Response> object.
 650
 651     my $res = $c->res;
 652
 653 =item $class->setup
 654
 655 Setup.
 656
 657     MyApp->setup;
 658
 659 =cut
 660
 661 sub setup {
 662     my $self = shift;
 663
 664     # Initialize our data structure
 665     $self->components( {} );
 666
 667     $self->setup_components;
 668
 669     if ( $self->debug ) {
 670         my $t = Text::ASCIITable->new;
 671         $t->setOptions( 'hide_HeadRow', 1 );
 672         $t->setOptions( 'hide_HeadLine', 1 );
 673         $t->setCols('Class');
 674         $t->setColWidth( 'Class', 75, 1 );
 675         $t->addRow($_) for sort keys %{ $self->components };
 676         $self->log->debug( 'Loaded components', $t->draw )
 677           if ( @{ $t->{tbl_rows} } );
 678     }
 679
 680     # Add our self to components, since we are also a component
 681     $self->components->{ $self } = $self;
 682
 683     $self->setup_actions;
 684
 685     if ( $self->debug ) {
 686         my $name = $self->config->{name} || 'Application';
 687         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 688     }
 689 }
 690
 691 =item $class->setup_components
 692
 693 Setup components.
 694
 695 =cut
 696
 697 sub setup_components {
 698     my $self = shift;
 699
 700     my $callback = sub {
 701         my ( $component, $context ) = @_;
 702
 703         unless ( $component->isa('Catalyst::Base') ) {
 704             return $component;
 705         }
 706
 707         my $suffix = Catalyst::Utils::class2classsuffix($component);
 708         my $config = $self->config->{$suffix} || {};
 709
 710         my $instance;
 711
 712         eval {
 713             $instance = $component->new( $context, $config );
 714         };
 715
 716         if ( my $error = $@ ) {
 717             chomp $error;
 718             die qq/Couldn't instantiate component "$component", "$error"/;
 719         }
 720
 721         return $instance;
 722     };
 723
 724     eval {
 725         Module::Pluggable::Fast->import(
 726             name     => '_components',
 727             search   => [
 728                 "$self\::Controller", "$self\::C",
 729                 "$self\::Model",      "$self\::M",
 730                 "$self\::View",       "$self\::V"
 731             ],
 732             callback => $callback
 733         );
 734     };
 735
 736     if ( my $error = $@ ) {
 737         chomp $error;
 738         die qq/Couldn't load components "$error"/;
 739     }
 740
 741     for my $component ( $self->_components($self) ) {
 742         $self->components->{ ref $component || $component } = $component;
 743     }
 744 }
 745
 746 =item $c->state
 747
 748 Contains the return value of the last executed action.
 749
 750 =item $c->stash
 751
 752 Returns a hashref containing all your data.
 753
 754     $c->stash->{foo} ||= 'yada';
 755     print $c->stash->{foo};
 756
 757 =cut
 758
 759 sub stash {
 760     my $self = shift;
 761     if (@_) {
 762         my $stash = @_ > 1 ? {@_} : $_[0];
 763         while ( my ( $key, $val ) = each %$stash ) {
 764             $self->{stash}->{$key} = $val;
 765         }
 766     }
 767     return $self->{stash};
 768 }
 769
 770 =back
 771
 772 =head1 AUTHOR
 773
 774 Sebastian Riedel, C<sri@cpan.org>
 775
 776 =head1 COPYRIGHT
 777
 778 This program is free software, you can redistribute it and/or modify it under
 779 the same terms as Perl itself.
 780
 781 =cut
 782
 783 1;