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