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