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