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