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 '', map { '<code class="error">'  .  encode_entities($_) . '</code>' } @{ $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         code.error {
 366             display: block;
 367             margin: 1em 0;
 368             overflow: auto;
 369             white-space: pre;
 370         }
 371     </style>
 372 </head>
 373 <body>
 374     <div class="box">
 375         <div class="error">$error</div>
 376         <div class="infos">$infos</div>
 377         <div class="name">$name</div>
 378     </div>
 379 </body>
 380 </html>
 381
 382 }
 383
 384 =item $c->finalize_headers
 385
 386 Finalize headers.
 387
 388 =cut
 389
 390 sub finalize_headers { }
 391
 392 =item $c->handler( $class, @arguments )
 393
 394 Handles the request.
 395
 396 =cut
 397
 398 sub handler {
 399     my ( $class, @arguments ) = @_;
 400
 401     # Always expect worst case!
 402     my $status = -1;
 403     eval {
 404         my @stats = ();
 405
 406         my $handler = sub {
 407             my $c = $class->prepare(@arguments);
 408             $c->{stats} = \@stats;
 409             $c->dispatch;
 410             return $c->finalize;
 411         };
 412
 413         if ( $class->debug ) {
 414             my $elapsed;
 415             ( $elapsed, $status ) = $class->benchmark($handler);
 416             $elapsed = sprintf '%f', $elapsed;
 417             my $av = sprintf '%.3f',
 418               ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
 419             my $t = Text::ASCIITable->new;
 420             $t->setCols( 'Action', 'Time' );
 421             $t->setColWidth( 'Action', 64, 1 );
 422             $t->setColWidth( 'Time',   9,  1 );
 423
 424             for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
 425             $class->log->info( "Request took ${elapsed}s ($av/s)\n" . $t->draw );
 426         }
 427         else { $status = &$handler }
 428
 429     };
 430
 431     if ( my $error = $@ ) {
 432         chomp $error;
 433         $class->log->error(qq/Caught exception in engine "$error"/);
 434     }
 435
 436     $COUNT++;
 437     return $status;
 438 }
 439
 440 =item $c->prepare(@arguments)
 441
 442 Turns the engine-specific request( Apache, CGI ... )
 443 into a Catalyst context .
 444
 445 =cut
 446
 447 sub prepare {
 448     my ( $class, @arguments ) = @_;
 449
 450     my $c = bless {
 451         counter => {},
 452         depth   => 0,
 453         request => Catalyst::Request->new(
 454             {
 455                 arguments  => [],
 456                 cookies    => {},
 457                 headers    => HTTP::Headers->new,
 458                 parameters => {},
 459                 secure     => 0,
 460                 snippets   => [],
 461                 uploads    => {}
 462             }
 463         ),
 464         response => Catalyst::Response->new(
 465             {
 466                 body    => '',
 467                 cookies => {},
 468                 headers => HTTP::Headers->new( 'Content-Length' => 0 ),
 469                 status  => 200
 470             }
 471         ),
 472         stash => {},
 473         state => 0
 474     }, $class;
 475
 476     if ( $c->debug ) {
 477         my $secs = time - $START || 1;
 478         my $av = sprintf '%.3f', $COUNT / $secs;
 479         $c->log->debug('**********************************');
 480         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 481         $c->log->debug('**********************************');
 482         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 483     }
 484
 485     $c->prepare_request(@arguments);
 486     $c->prepare_connection;
 487     $c->prepare_headers;
 488     $c->prepare_cookies;
 489     $c->prepare_path;
 490     $c->prepare_action;
 491
 492     my $method  = $c->req->method  || '';
 493     my $path    = $c->req->path    || '';
 494     my $address = $c->req->address || '';
 495
 496     $c->log->debug(qq/"$method" request for "$path" from $address/)
 497       if $c->debug;
 498
 499     if ( $c->request->method eq 'POST' and $c->request->content_length ) {
 500
 501         if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
 502             $c->prepare_parameters;
 503         }
 504         elsif ( $c->req->content_type eq 'multipart/form-data' ) {
 505             $c->prepare_parameters;
 506             $c->prepare_uploads;
 507         }
 508         else {
 509             $c->prepare_body;
 510         }
 511     }
 512
 513     if ( $c->request->method eq 'GET' ) {
 514         $c->prepare_parameters;
 515     }
 516
 517     if ( $c->debug && keys %{ $c->req->params } ) {
 518         my $t = Text::ASCIITable->new;
 519         $t->setCols( 'Key', 'Value' );
 520         $t->setColWidth( 'Key',   37, 1 );
 521         $t->setColWidth( 'Value', 36, 1 );
 522         for my $key ( sort keys %{ $c->req->params } ) {
 523             my $param = $c->req->params->{$key};
 524             my $value = defined($param) ? $param : '';
 525             $t->addRow( $key, $value );
 526         }
 527         $c->log->debug( "Parameters are:\n" . $t->draw );
 528     }
 529
 530     return $c;
 531 }
 532
 533 =item $c->prepare_action
 534
 535 Prepare action.
 536
 537 =cut
 538
 539 sub prepare_action {
 540     my $c    = shift;
 541     my $path = $c->req->path;
 542     my @path = split /\//, $c->req->path;
 543     $c->req->args( \my @args );
 544
 545     while (@path) {
 546         $path = join '/', @path;
 547         if ( my $result = ${ $c->get_action($path) }[0] ) {
 548
 549             # It's a regex
 550             if ($#$result) {
 551                 my $match    = $result->[1];
 552                 my @snippets = @{ $result->[2] };
 553                 $c->log->debug(
 554                     qq/Requested action is "$path" and matched "$match"/)
 555                   if $c->debug;
 556                 $c->log->debug(
 557                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 558                   if ( $c->debug && @snippets );
 559                 $c->req->action($match);
 560                 $c->req->snippets( \@snippets );
 561             }
 562
 563             else {
 564                 $c->req->action($path);
 565                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 566             }
 567
 568             $c->req->match($path);
 569             last;
 570         }
 571         unshift @args, pop @path;
 572     }
 573
 574     unless ( $c->req->action ) {
 575         $c->req->action('default');
 576         $c->req->match('');
 577     }
 578
 579     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 580       if ( $c->debug && @args );
 581 }
 582
 583 =item $c->prepare_body
 584
 585 Prepare message body.
 586
 587 =cut
 588
 589 sub prepare_body { }
 590
 591 =item $c->prepare_connection
 592
 593 Prepare connection.
 594
 595 =cut
 596
 597 sub prepare_connection { }
 598
 599 =item $c->prepare_cookies
 600
 601 Prepare cookies.
 602
 603 =cut
 604
 605 sub prepare_cookies {
 606     my $c = shift;
 607
 608     if ( my $header = $c->request->header('Cookie') ) {
 609         $c->req->cookies( { CGI::Cookie->parse($header) } );
 610     }
 611 }
 612
 613 =item $c->prepare_headers
 614
 615 Prepare headers.
 616
 617 =cut
 618
 619 sub prepare_headers { }
 620
 621 =item $c->prepare_parameters
 622
 623 Prepare parameters.
 624
 625 =cut
 626
 627 sub prepare_parameters { }
 628
 629 =item $c->prepare_path
 630
 631 Prepare path and base.
 632
 633 =cut
 634
 635 sub prepare_path { }
 636
 637 =item $c->prepare_request
 638
 639 Prepare the engine request.
 640
 641 =cut
 642
 643 sub prepare_request { }
 644
 645 =item $c->prepare_uploads
 646
 647 Prepare uploads.
 648
 649 =cut
 650
 651 sub prepare_uploads { }
 652
 653 =item $c->run
 654
 655 Starts the engine.
 656
 657 =cut
 658
 659 sub run { }
 660
 661 =item $c->request
 662
 663 =item $c->req
 664
 665 Returns a C<Catalyst::Request> object.
 666
 667     my $req = $c->req;
 668
 669 =item $c->response
 670
 671 =item $c->res
 672
 673 Returns a C<Catalyst::Response> object.
 674
 675     my $res = $c->res;
 676
 677 =item $c->state
 678
 679 Contains the return value of the last executed action.
 680
 681 =item $c->stash
 682
 683 Returns a hashref containing all your data.
 684
 685     $c->stash->{foo} ||= 'yada';
 686     print $c->stash->{foo};
 687
 688 =cut
 689
 690 sub stash {
 691     my $self = shift;
 692     if (@_) {
 693         my $stash = @_ > 1 ? {@_} : $_[0];
 694         while ( my ( $key, $val ) = each %$stash ) {
 695             $self->{stash}->{$key} = $val;
 696         }
 697     }
 698     return $self->{stash};
 699 }
 700
 701 =back
 702
 703 =head1 AUTHOR
 704
 705 Sebastian Riedel, C<sri@cpan.org>
 706
 707 =head1 COPYRIGHT
 708
 709 This program is free software, you can redistribute it and/or modify it under
 710 the same terms as Perl itself.
 711
 712 =cut
 713
 714 1;