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