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