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