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