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, @arguments )
 365
 366 Handles the request.
 367
 368 =cut
 369
 370 sub handler {
 371     my ( $class, @arguments ) = @_;
 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(@arguments);
 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(@arguments)
 414
 415 Turns the engine-specific request( Apache, CGI ... )
 416 into a Catalyst context .
 417
 418 =cut
 419
 420 sub prepare {
 421     my ( $class, @arguments ) = @_;
 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(@arguments);
 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->run
 627
 628 Starts the engine.
 629
 630 =cut
 631
 632 sub run { }
 633
 634 =item $c->request
 635
 636 =item $c->req
 637
 638 Returns a C<Catalyst::Request> object.
 639
 640     my $req = $c->req;
 641
 642 =item $c->response
 643
 644 =item $c->res
 645
 646 Returns a C<Catalyst::Response> object.
 647
 648     my $res = $c->res;
 649
 650 =item $class->setup
 651
 652 Setup.
 653
 654     MyApp->setup;
 655
 656 =cut
 657
 658 sub setup {
 659     my $self = shift;
 660     $self->setup_components;
 661     if ( $self->debug ) {
 662         my $name = $self->config->{name} || 'Application';
 663         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 664     }
 665 }
 666
 667 =item $class->setup_components
 668
 669 Setup components.
 670
 671 =cut
 672
 673 sub setup_components {
 674     my $self = shift;
 675
 676     # Components
 677     my $class = ref $self || $self;
 678     eval <<"";
 679         package $class;
 680         import Module::Pluggable::Fast
 681           name   => '_components',
 682           search => [
 683             '$class\::Controller', '$class\::C',
 684             '$class\::Model',      '$class\::M',
 685             '$class\::View',       '$class\::V'
 686           ];
 687
 688     if ( my $error = $@ ) {
 689         chomp $error;
 690         die qq/Couldn't load components "$error"/;
 691     }
 692
 693     $self->components( {} );
 694     my @comps;
 695     for my $comp ( $self->_components($self) ) {
 696         $self->components->{ ref $comp } = $comp;
 697         push @comps, $comp;
 698     }
 699
 700     my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
 701     $t->setCols('Class');
 702     $t->setColWidth( 'Class', 75, 1 );
 703     $t->addRow($_) for sort keys %{ $self->components };
 704     $self->log->debug( 'Loaded components', $t->draw )
 705       if ( @{ $t->{tbl_rows} } && $self->debug );
 706
 707     $self->setup_actions( [ $self, @comps ] );
 708 }
 709
 710 =item $c->state
 711
 712 Contains the return value of the last executed action.
 713
 714 =item $c->stash
 715
 716 Returns a hashref containing all your data.
 717
 718     $c->stash->{foo} ||= 'yada';
 719     print $c->stash->{foo};
 720
 721 =cut
 722
 723 sub stash {
 724     my $self = shift;
 725     if (@_) {
 726         my $stash = @_ > 1 ? {@_} : $_[0];
 727         while ( my ( $key, $val ) = each %$stash ) {
 728             $self->{stash}->{$key} = $val;
 729         }
 730     }
 731     return $self->{stash};
 732 }
 733
 734 =back
 735
 736 =head1 AUTHOR
 737
 738 Sebastian Riedel, C<sri@cpan.org>
 739
 740 =head1 COPYRIGHT
 741
 742 This program is free software, you can redistribute it and/or modify it under
 743 the same terms as Perl itself.
 744
 745 =cut
 746
 747 1;