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 } ) ? 1 : 0 ) }
 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 $address  = $c->req->address  || '';
 471
 472     $c->log->debug(qq/"$method" request for "$path" from $address/)
 473       if $c->debug;
 474
 475     if ( $c->request->method eq 'POST' and $c->request->content_length ) {
 476
 477         if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
 478             $c->prepare_parameters;
 479         }
 480         elsif ( $c->req->content_type eq 'multipart/form-data' ) {
 481             $c->prepare_parameters;
 482             $c->prepare_uploads;
 483         }
 484         else {
 485             $c->prepare_body;
 486         }
 487     }
 488
 489     if ( $c->request->method eq 'GET' ) {
 490         $c->prepare_parameters;
 491     }
 492
 493     if ( $c->debug && keys %{ $c->req->params } ) {
 494         my $t = Text::ASCIITable->new;
 495         $t->setCols( 'Key', 'Value' );
 496         $t->setColWidth( 'Key',   37, 1 );
 497         $t->setColWidth( 'Value', 36, 1 );
 498         for my $key ( sort keys %{ $c->req->params } ) {
 499             my $param = $c->req->params->{$key};
 500             my $value = defined($param) ? $param : '';
 501             $t->addRow( $key, $value );
 502         }
 503         $c->log->debug( 'Parameters are', $t->draw );
 504     }
 505
 506     return $c;
 507 }
 508
 509 =item $c->prepare_action
 510
 511 Prepare action.
 512
 513 =cut
 514
 515 sub prepare_action {
 516     my $c    = shift;
 517     my $path = $c->req->path;
 518     my @path = split /\//, $c->req->path;
 519     $c->req->args( \my @args );
 520
 521     while (@path) {
 522         $path = join '/', @path;
 523         if ( my $result = ${ $c->get_action($path) }[0] ) {
 524
 525             # It's a regex
 526             if ($#$result) {
 527                 my $match    = $result->[1];
 528                 my @snippets = @{ $result->[2] };
 529                 $c->log->debug(
 530                     qq/Requested action is "$path" and matched "$match"/)
 531                   if $c->debug;
 532                 $c->log->debug(
 533                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 534                   if ( $c->debug && @snippets );
 535                 $c->req->action($match);
 536                 $c->req->snippets( \@snippets );
 537             }
 538
 539             else {
 540                 $c->req->action($path);
 541                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 542             }
 543
 544             $c->req->match($path);
 545             last;
 546         }
 547         unshift @args, pop @path;
 548     }
 549
 550     unless ( $c->req->action ) {
 551         $c->req->action('default');
 552         $c->req->match('');
 553     }
 554
 555     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 556       if ( $c->debug && @args );
 557 }
 558
 559 =item $c->prepare_body
 560
 561 Prepare message body.
 562
 563 =cut
 564
 565 sub prepare_body { }
 566
 567 =item $c->prepare_connection
 568
 569 Prepare connection.
 570
 571 =cut
 572
 573 sub prepare_connection { }
 574
 575 =item $c->prepare_cookies
 576
 577 Prepare cookies.
 578
 579 =cut
 580
 581 sub prepare_cookies {
 582     my $c = shift;
 583
 584     if ( my $header = $c->request->header('Cookie') ) {
 585         $c->req->cookies( { CGI::Cookie->parse($header) } );
 586     }
 587 }
 588
 589 =item $c->prepare_headers
 590
 591 Prepare headers.
 592
 593 =cut
 594
 595 sub prepare_headers { }
 596
 597 =item $c->prepare_parameters
 598
 599 Prepare parameters.
 600
 601 =cut
 602
 603 sub prepare_parameters { }
 604
 605 =item $c->prepare_path
 606
 607 Prepare path and base.
 608
 609 =cut
 610
 611 sub prepare_path { }
 612
 613 =item $c->prepare_request
 614
 615 Prepare the engine request.
 616
 617 =cut
 618
 619 sub prepare_request { }
 620
 621 =item $c->prepare_uploads
 622
 623 Prepare uploads.
 624
 625 =cut
 626
 627 sub prepare_uploads { }
 628
 629 =item $c->run
 630
 631 Starts the engine.
 632
 633 =cut
 634
 635 sub run { }
 636
 637 =item $c->request
 638
 639 =item $c->req
 640
 641 Returns a C<Catalyst::Request> object.
 642
 643     my $req = $c->req;
 644
 645 =item $c->response
 646
 647 =item $c->res
 648
 649 Returns a C<Catalyst::Response> object.
 650
 651     my $res = $c->res;
 652
 653 =item $class->setup
 654
 655 Setup.
 656
 657     MyApp->setup;
 658
 659 =cut
 660
 661 sub setup {
 662     my $self = shift;
 663     $self->setup_components;
 664     if ( $self->debug ) {
 665         my $name = $self->config->{name} || 'Application';
 666         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 667     }
 668 }
 669
 670 =item $class->setup_components
 671
 672 Setup components.
 673
 674 =cut
 675
 676 sub setup_components {
 677     my $self = shift;
 678
 679     # Components
 680     my $class = ref $self || $self;
 681     eval <<"";
 682         package $class;
 683         import Module::Pluggable::Fast
 684           name   => '_components',
 685           search => [
 686             '$class\::Controller', '$class\::C',
 687             '$class\::Model',      '$class\::M',
 688             '$class\::View',       '$class\::V'
 689           ];
 690
 691     if ( my $error = $@ ) {
 692         chomp $error;
 693         die qq/Couldn't load components "$error"/;
 694     }
 695
 696     $self->components( {} );
 697     my @comps;
 698     for my $comp ( $self->_components($self) ) {
 699         $self->components->{ ref $comp } = $comp;
 700         push @comps, $comp;
 701     }
 702
 703     my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
 704     $t->setCols('Class');
 705     $t->setColWidth( 'Class', 75, 1 );
 706     $t->addRow($_) for sort keys %{ $self->components };
 707     $self->log->debug( 'Loaded components', $t->draw )
 708       if ( @{ $t->{tbl_rows} } && $self->debug );
 709
 710     $self->setup_actions( [ $self, @comps ] );
 711 }
 712
 713 =item $c->state
 714
 715 Contains the return value of the last executed action.
 716
 717 =item $c->stash
 718
 719 Returns a hashref containing all your data.
 720
 721     $c->stash->{foo} ||= 'yada';
 722     print $c->stash->{foo};
 723
 724 =cut
 725
 726 sub stash {
 727     my $self = shift;
 728     if (@_) {
 729         my $stash = @_ > 1 ? {@_} : $_[0];
 730         while ( my ( $key, $val ) = each %$stash ) {
 731             $self->{stash}->{$key} = $val;
 732         }
 733     }
 734     return $self->{stash};
 735 }
 736
 737 =back
 738
 739 =head1 AUTHOR
 740
 741 Sebastian Riedel, C<sri@cpan.org>
 742
 743 =head1 COPYRIGHT
 744
 745 This program is free software, you can redistribute it and/or modify it under
 746 the same terms as Perl itself.
 747
 748 =cut
 749
 750 1;