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_body
 223
 224 Finalize body.
 225
 226 =cut
 227
 228 sub finalize_body { }
 229
 230 =item $c->finalize_cookies
 231
 232 Finalize cookies.
 233
 234 =cut
 235
 236 sub finalize_cookies {
 237     my $c = shift;
 238
 239     while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
 240         my $cookie = CGI::Cookie->new(
 241             -name    => $name,
 242             -value   => $cookie->{value},
 243             -expires => $cookie->{expires},
 244             -domain  => $cookie->{domain},
 245             -path    => $cookie->{path},
 246             -secure  => $cookie->{secure} || 0
 247         );
 248
 249         $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
 250     }
 251 }
 252
 253 =item $c->finalize_error
 254
 255 Finalize error.
 256
 257 =cut
 258
 259 sub finalize_error {
 260     my $c = shift;
 261
 262     $c->res->headers->content_type('text/html');
 263     my $name = $c->config->{name} || 'Catalyst Application';
 264
 265     my ( $title, $error, $infos );
 266     if ( $c->debug ) {
 267         $error = join '<br/>', @{ $c->error };
 268         $error ||= 'No output';
 269         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 270         my $req   = encode_entities Dumper $c->req;
 271         my $res   = encode_entities Dumper $c->res;
 272         my $stash = encode_entities Dumper $c->stash;
 273         $infos = <<"";
 274 <br/>
 275 <b><u>Request</u></b><br/>
 276 <pre>$req</pre>
 277 <b><u>Response</u></b><br/>
 278 <pre>$res</pre>
 279 <b><u>Stash</u></b><br/>
 280 <pre>$stash</pre>
 281
 282     }
 283     else {
 284         $title = $name;
 285         $error = '';
 286         $infos = <<"";
 287 <pre>
 288 (en) Please come back later
 289 (de) Bitte versuchen sie es spaeter nocheinmal
 290 (nl) Gelieve te komen later terug
 291 (no) Vennligst prov igjen senere
 292 (fr) Veuillez revenir plus tard
 293 (es) Vuelto por favor mas adelante
 294 (pt) Voltado por favor mais tarde
 295 (it) Ritornato prego più successivamente
 296 </pre>
 297
 298         $name = '';
 299     }
 300     $c->res->body( <<"" );
 301 <html>
 302 <head>
 303     <title>$title</title>
 304     <style type="text/css">
 305         body {
 306             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 307                          Tahoma, Arial, helvetica, sans-serif;
 308             color: #ddd;
 309             background-color: #eee;
 310             margin: 0px;
 311             padding: 0px;
 312         }
 313         div.box {
 314             background-color: #ccc;
 315             border: 1px solid #aaa;
 316             padding: 4px;
 317             margin: 10px;
 318             -moz-border-radius: 10px;
 319         }
 320         div.error {
 321             background-color: #977;
 322             border: 1px solid #755;
 323             padding: 8px;
 324             margin: 4px;
 325             margin-bottom: 10px;
 326             -moz-border-radius: 10px;
 327         }
 328         div.infos {
 329             background-color: #797;
 330             border: 1px solid #575;
 331             padding: 8px;
 332             margin: 4px;
 333             margin-bottom: 10px;
 334             -moz-border-radius: 10px;
 335         }
 336         div.name {
 337             background-color: #779;
 338             border: 1px solid #557;
 339             padding: 8px;
 340             margin: 4px;
 341             -moz-border-radius: 10px;
 342         }
 343     </style>
 344 </head>
 345 <body>
 346     <div class="box">
 347         <div class="error">$error</div>
 348         <div class="infos">$infos</div>
 349         <div class="name">$name</div>
 350     </div>
 351 </body>
 352 </html>
 353
 354 }
 355
 356 =item $c->finalize_headers
 357
 358 Finalize headers.
 359
 360 =cut
 361
 362 sub finalize_headers { }
 363
 364 =item $c->handler( $class, $engine )
 365
 366 Handles the request.
 367
 368 =cut
 369
 370 sub handler {
 371     my ( $class, $engine ) = @_;
 372
 373     # Always expect worst case!
 374     my $status = -1;
 375     eval {
 376         my @stats = ();
 377
 378         my $handler = sub {
 379             my $c = $class->prepare($engine);
 380             $c->{stats} = \@stats;
 381             $c->dispatch;
 382             return $c->finalize;
 383         };
 384
 385         if ( $class->debug ) {
 386             my $elapsed;
 387             ( $elapsed, $status ) = $class->benchmark($handler);
 388             $elapsed = sprintf '%f', $elapsed;
 389             my $av = sprintf '%.3f',
 390               ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
 391             my $t = Text::ASCIITable->new;
 392             $t->setCols( 'Action', 'Time' );
 393             $t->setColWidth( 'Action', 64, 1 );
 394             $t->setColWidth( 'Time',   9,  1 );
 395
 396             for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
 397             $class->log->info( "Request took $elapsed" . "s ($av/s)",
 398                 $t->draw );
 399         }
 400         else { $status = &$handler }
 401
 402     };
 403
 404     if ( my $error = $@ ) {
 405         chomp $error;
 406         $class->log->error(qq/Caught exception in engine "$error"/);
 407     }
 408
 409     $COUNT++;
 410     return $status;
 411 }
 412
 413 =item $c->prepare($engine)
 414
 415 Turns the engine-specific request( Apache, CGI ... )
 416 into a Catalyst context .
 417
 418 =cut
 419
 420 sub prepare {
 421     my ( $class, $engine ) = @_;
 422
 423     my $c = bless {
 424         counter => {},
 425         request => Catalyst::Request->new(
 426             {
 427                 arguments  => [],
 428                 cookies    => {},
 429                 headers    => HTTP::Headers->new,
 430                 parameters => {},
 431                 secure     => 0,
 432                 snippets   => [],
 433                 uploads    => {}
 434             }
 435         ),
 436         response => Catalyst::Response->new(
 437             {
 438                 body    => '',
 439                 cookies => {},
 440                 headers => HTTP::Headers->new,
 441                 status  => 200
 442             }
 443         ),
 444         stash => {},
 445         state => 0
 446     }, $class;
 447
 448     if ( $c->debug ) {
 449         my $secs = time - $START || 1;
 450         my $av = sprintf '%.3f', $COUNT / $secs;
 451         $c->log->debug('**********************************');
 452         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 453         $c->log->debug('**********************************');
 454         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 455     }
 456
 457     $c->prepare_request($engine);
 458     $c->prepare_connection;
 459     $c->prepare_headers;
 460     $c->prepare_cookies;
 461     $c->prepare_path;
 462     $c->prepare_action;
 463
 464     my $method   = $c->req->method   || '';
 465     my $path     = $c->req->path     || '';
 466     my $hostname = $c->req->hostname || '';
 467     my $address  = $c->req->address  || '';
 468
 469     $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
 470       if $c->debug;
 471
 472     if ( $c->request->method eq 'POST' and $c->request->content_length ) {
 473
 474         if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
 475             $c->prepare_parameters;
 476         }
 477         elsif ( $c->req->content_type eq 'multipart/form-data' ) {
 478             $c->prepare_parameters;
 479             $c->prepare_uploads;
 480         }
 481         else {
 482             $c->prepare_body;
 483         }
 484     }
 485
 486     if ( $c->request->method eq 'GET' ) {
 487         $c->prepare_parameters;
 488     }
 489
 490     if ( $c->debug && keys %{ $c->req->params } ) {
 491         my $t = Text::ASCIITable->new;
 492         $t->setCols( 'Key', 'Value' );
 493         $t->setColWidth( 'Key',   37, 1 );
 494         $t->setColWidth( 'Value', 36, 1 );
 495         for my $key ( sort keys %{ $c->req->params } ) {
 496             my $param = $c->req->params->{$key};
 497             my $value = defined($param) ? $param : '';
 498             $t->addRow( $key, $value );
 499         }
 500         $c->log->debug( 'Parameters are', $t->draw );
 501     }
 502
 503     return $c;
 504 }
 505
 506 =item $c->prepare_action
 507
 508 Prepare action.
 509
 510 =cut
 511
 512 sub prepare_action {
 513     my $c    = shift;
 514     my $path = $c->req->path;
 515     my @path = split /\//, $c->req->path;
 516     $c->req->args( \my @args );
 517
 518     while (@path) {
 519         $path = join '/', @path;
 520         if ( my $result = ${ $c->get_action($path) }[0] ) {
 521
 522             # It's a regex
 523             if ($#$result) {
 524                 my $match    = $result->[1];
 525                 my @snippets = @{ $result->[2] };
 526                 $c->log->debug(
 527                     qq/Requested action is "$path" and matched "$match"/)
 528                   if $c->debug;
 529                 $c->log->debug(
 530                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 531                   if ( $c->debug && @snippets );
 532                 $c->req->action($match);
 533                 $c->req->snippets( \@snippets );
 534             }
 535
 536             else {
 537                 $c->req->action($path);
 538                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 539             }
 540
 541             $c->req->match($path);
 542             last;
 543         }
 544         unshift @args, pop @path;
 545     }
 546
 547     unless ( $c->req->action ) {
 548         $c->req->action('default');
 549         $c->req->match('');
 550     }
 551
 552     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 553       if ( $c->debug && @args );
 554 }
 555
 556 =item $c->prepare_body
 557
 558 Prepare message body.
 559
 560 =cut
 561
 562 sub prepare_body { }
 563
 564 =item $c->prepare_connection
 565
 566 Prepare connection.
 567
 568 =cut
 569
 570 sub prepare_connection { }
 571
 572 =item $c->prepare_cookies
 573
 574 Prepare cookies.
 575
 576 =cut
 577
 578 sub prepare_cookies {
 579     my $c = shift;
 580
 581     if ( my $header = $c->request->header('Cookie') ) {
 582         $c->req->cookies( { CGI::Cookie->parse($header) } );
 583     }
 584 }
 585
 586 =item $c->prepare_headers
 587
 588 Prepare headers.
 589
 590 =cut
 591
 592 sub prepare_headers { }
 593
 594 =item $c->prepare_parameters
 595
 596 Prepare parameters.
 597
 598 =cut
 599
 600 sub prepare_parameters { }
 601
 602 =item $c->prepare_path
 603
 604 Prepare path and base.
 605
 606 =cut
 607
 608 sub prepare_path { }
 609
 610 =item $c->prepare_request
 611
 612 Prepare the engine request.
 613
 614 =cut
 615
 616 sub prepare_request { }
 617
 618 =item $c->prepare_uploads
 619
 620 Prepare uploads.
 621
 622 =cut
 623
 624 sub prepare_uploads { }
 625
 626 =item $c->retrieve_components
 627
 628 Retrieve Components.
 629
 630 =cut
 631
 632 sub retrieve_components {
 633     my $self = shift;
 634
 635     my $class = ref $self || $self;
 636     eval <<"";
 637         package $class;
 638         import Module::Pluggable::Fast
 639           name    => '_components',
 640           search  => [
 641             '$class\::Controller', '$class\::C',
 642             '$class\::Model',      '$class\::M',
 643             '$class\::View',       '$class\::V'
 644           ],
 645           require => 1;
 646
 647     if ( my $error = $@ ) {
 648         chomp $error;
 649         die qq/Couldn't load components "$error"/;
 650     }
 651
 652     return $self->_components;
 653 }
 654
 655 =item $c->run
 656
 657 Starts the engine.
 658
 659 =cut
 660
 661 sub run { }
 662
 663 =item $c->request
 664
 665 =item $c->req
 666
 667 Returns a C<Catalyst::Request> object.
 668
 669     my $req = $c->req;
 670
 671 =item $c->response
 672
 673 =item $c->res
 674
 675 Returns a C<Catalyst::Response> object.
 676
 677     my $res = $c->res;
 678
 679 =item $class->setup
 680
 681 Setup.
 682
 683     MyApp->setup;
 684
 685 =cut
 686
 687 sub setup {
 688     my $self = shift;
 689     $self->setup_components;
 690     if ( $self->debug ) {
 691         my $name = $self->config->{name} || 'Application';
 692         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 693     }
 694 }
 695
 696 =item $class->setup_components
 697
 698 Setup components.
 699
 700 =cut
 701
 702 sub setup_components {
 703     my $self = shift;
 704
 705     # Components
 706     my $class = ref $self || $self;
 707     eval <<"";
 708         package $class;
 709         import Module::Pluggable::Fast
 710           name   => '_components',
 711           search => [
 712             '$class\::Controller', '$class\::C',
 713             '$class\::Model',      '$class\::M',
 714             '$class\::View',       '$class\::V'
 715           ];
 716
 717     if ( my $error = $@ ) {
 718         chomp $error;
 719         die qq/Couldn't load components "$error"/;
 720     }
 721
 722     $self->components( {} );
 723     my @comps;
 724     for my $comp ( $self->_components($self) ) {
 725         $self->components->{ ref $comp } = $comp;
 726         push @comps, $comp;
 727     }
 728
 729     my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
 730     $t->setCols('Class');
 731     $t->setColWidth( 'Class', 75, 1 );
 732     $t->addRow($_) for sort keys %{ $self->components };
 733     $self->log->debug( 'Loaded components', $t->draw )
 734       if ( @{ $t->{tbl_rows} } && $self->debug );
 735
 736     $self->setup_actions( [ $self, @comps ] );
 737 }
 738
 739 =item $c->state
 740
 741 Contains the return value of the last executed action.
 742
 743 =item $c->stash
 744
 745 Returns a hashref containing all your data.
 746
 747     $c->stash->{foo} ||= 'yada';
 748     print $c->stash->{foo};
 749
 750 =cut
 751
 752 sub stash {
 753     my $self = shift;
 754     if (@_) {
 755         my $stash = @_ > 1 ? {@_} : $_[0];
 756         while ( my ( $key, $val ) = each %$stash ) {
 757             $self->{stash}->{$key} = $val;
 758         }
 759     }
 760     return $self->{stash};
 761 }
 762
 763 =back
 764
 765 =head1 AUTHOR
 766
 767 Sebastian Riedel, C<sri@cpan.org>
 768
 769 =head1 COPYRIGHT
 770
 771 This program is free software, you can redistribute it and/or modify it under
 772 the same terms as Perl itself.
 773
 774 =cut
 775
 776 1;