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