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