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