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 && $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, $engine )
 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', ( $elapsed == 0 ? '??' : (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($engine)
 387
 388 Turns the engine-specific request( Apache, CGI ... )
 389 into a Catalyst context .
 390
 391 =cut
 392
 393 sub prepare {
 394     my ( $class, $engine ) = @_;
 395
 396     my $c = bless {
 397         request => Catalyst::Request->new(
 398             {
 399                 arguments  => [],
 400                 cookies    => {},
 401                 headers    => HTTP::Headers->new,
 402                 parameters => {},
 403                 secure     => 0,
 404                 snippets   => [],
 405                 uploads    => {}
 406             }
 407         ),
 408         response => Catalyst::Response->new(
 409             {
 410                 body    => '',
 411                 cookies => {},
 412                 headers => HTTP::Headers->new,
 413                 status  => 200
 414             }
 415         ),
 416         stash => {},
 417         state => 0
 418     }, $class;
 419
 420     if ( $c->debug ) {
 421         my $secs = time - $START || 1;
 422         my $av = sprintf '%.3f', $COUNT / $secs;
 423         $c->log->debug('**********************************');
 424         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 425         $c->log->debug('**********************************');
 426         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 427     }
 428
 429     $c->prepare_request($engine);
 430     $c->prepare_connection;
 431     $c->prepare_headers;
 432     $c->prepare_cookies;
 433     $c->prepare_path;
 434     $c->prepare_action;
 435
 436     my $method   = $c->req->method   || '';
 437     my $path     = $c->req->path     || '';
 438     my $hostname = $c->req->hostname || '';
 439     my $address  = $c->req->address  || '';
 440
 441     $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
 442       if $c->debug;
 443
 444     if ( $c->request->method eq 'POST' and $c->request->content_length ) {
 445
 446         if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
 447             $c->prepare_parameters;
 448         }
 449         elsif ( $c->req->content_type eq 'multipart/form-data' ) {
 450             $c->prepare_parameters;
 451             $c->prepare_uploads;
 452         }
 453         else {
 454             $c->prepare_body;
 455         }
 456     }
 457
 458     if ( $c->request->method eq 'GET' ) {
 459         $c->prepare_parameters;
 460     }
 461
 462     if ( $c->debug && keys %{ $c->req->params } ) {
 463         my $t = Text::ASCIITable->new;
 464         $t->setCols( 'Key', 'Value' );
 465         $t->setColWidth( 'Key',   37, 1 );
 466         $t->setColWidth( 'Value', 36, 1 );
 467         for my $key ( sort keys %{ $c->req->params } ) {
 468             my $param = $c->req->params->{$key};
 469             my $value = defined($param) ? $param : '';
 470             $t->addRow( $key, $value );
 471         }
 472         $c->log->debug( 'Parameters are', $t->draw );
 473     }
 474
 475     return $c;
 476 }
 477
 478 =item $c->prepare_action
 479
 480 Prepare action.
 481
 482 =cut
 483
 484 sub prepare_action {
 485     my $c    = shift;
 486     my $path = $c->req->path;
 487     my @path = split /\//, $c->req->path;
 488     $c->req->args( \my @args );
 489
 490     while (@path) {
 491         $path = join '/', @path;
 492         if ( my $result = ${ $c->get_action($path) }[0] ) {
 493
 494             # It's a regex
 495             if ($#$result) {
 496                 my $match    = $result->[1];
 497                 my @snippets = @{ $result->[2] };
 498                 $c->log->debug(
 499                     qq/Requested action is "$path" and matched "$match"/)
 500                   if $c->debug;
 501                 $c->log->debug(
 502                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 503                   if ( $c->debug && @snippets );
 504                 $c->req->action($match);
 505                 $c->req->snippets( \@snippets );
 506             }
 507
 508             else {
 509                 $c->req->action($path);
 510                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 511             }
 512
 513             $c->req->match($path);
 514             last;
 515         }
 516         unshift @args, pop @path;
 517     }
 518
 519     unless ( $c->req->action ) {
 520         $c->req->action('default');
 521         $c->req->match('');
 522     }
 523
 524     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 525       if ( $c->debug && @args );
 526 }
 527
 528 =item $c->prepare_body
 529
 530 Prepare message body.
 531
 532 =cut
 533
 534 sub prepare_body { }
 535
 536 =item $c->prepare_connection
 537
 538 Prepare connection.
 539
 540 =cut
 541
 542 sub prepare_connection { }
 543
 544 =item $c->prepare_cookies
 545
 546 Prepare cookies.
 547
 548 =cut
 549
 550 sub prepare_cookies {
 551     my $c = shift;
 552
 553     if ( my $header = $c->request->header('Cookie') ) {
 554         $c->req->cookies( { CGI::Cookie->parse($header) } );
 555     }
 556 }
 557
 558 =item $c->prepare_headers
 559
 560 Prepare headers.
 561
 562 =cut
 563
 564 sub prepare_headers { }
 565
 566 =item $c->prepare_parameters
 567
 568 Prepare parameters.
 569
 570 =cut
 571
 572 sub prepare_parameters { }
 573
 574 =item $c->prepare_path
 575
 576 Prepare path and base.
 577
 578 =cut
 579
 580 sub prepare_path { }
 581
 582 =item $c->prepare_request
 583
 584 Prepare the engine request.
 585
 586 =cut
 587
 588 sub prepare_request { }
 589
 590 =item $c->prepare_uploads
 591
 592 Prepare uploads.
 593
 594 =cut
 595
 596 sub prepare_uploads { }
 597
 598 =item $c->run
 599
 600 Starts the engine.
 601
 602 =cut
 603
 604 sub run { }
 605
 606 =item $c->request
 607
 608 =item $c->req
 609
 610 Returns a C<Catalyst::Request> object.
 611
 612     my $req = $c->req;
 613
 614 =item $c->response
 615
 616 =item $c->res
 617
 618 Returns a C<Catalyst::Response> object.
 619
 620     my $res = $c->res;
 621
 622 =item $class->setup
 623
 624 Setup.
 625
 626     MyApp->setup;
 627
 628 =cut
 629
 630 sub setup {
 631     my $self = shift;
 632     $self->setup_components;
 633     if ( $self->debug ) {
 634         my $name = $self->config->{name} || 'Application';
 635         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 636     }
 637 }
 638
 639 =item $class->setup_components
 640
 641 Setup components.
 642
 643 =cut
 644
 645 sub setup_components {
 646     my $self = shift;
 647
 648     # Components
 649     my $class = ref $self || $self;
 650     eval <<"";
 651         package $class;
 652         import Module::Pluggable::Fast
 653           name   => '_components',
 654           search => [
 655             '$class\::Controller', '$class\::C',
 656             '$class\::Model',      '$class\::M',
 657             '$class\::View',       '$class\::V'
 658           ];
 659
 660     if ( my $error = $@ ) {
 661         chomp $error;
 662         die qq/Couldn't load components "$error"/;
 663     }
 664
 665     $self->components( {} );
 666     my @comps;
 667     for my $comp ( $self->_components($self) ) {
 668         $self->components->{ ref $comp } = $comp;
 669         push @comps, $comp;
 670     }
 671
 672     my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
 673     $t->setCols('Class');
 674     $t->setColWidth( 'Class', 75, 1 );
 675     $t->addRow($_) for keys %{ $self->components };
 676     $self->log->debug( 'Loaded components', $t->draw )
 677       if ( @{ $t->{tbl_rows} } && $self->debug );
 678
 679     $self->setup_actions( [ $self, @comps ] );
 680 }
 681
 682 =item $c->state
 683
 684 Contains the return value of the last executed action.
 685
 686 =item $c->stash
 687
 688 Returns a hashref containing all your data.
 689
 690     $c->stash->{foo} ||= 'yada';
 691     print $c->stash->{foo};
 692
 693 =cut
 694
 695 sub stash {
 696     my $self = shift;
 697     if ( @_ ) {
 698         my $stash = @_ > 1 ? {@_} : $_[0];
 699         while ( my ( $key, $val ) = each %$stash ) {
 700             $self->{stash}->{$key} = $val;
 701         }
 702     }
 703     return $self->{stash};
 704 }
 705
 706 =back
 707
 708 =head1 AUTHOR
 709
 710 Sebastian Riedel, C<sri@cpan.org>
 711
 712 =head1 COPYRIGHT
 713
 714 This program is free software, you can redistribute it and/or modify it under
 715 the same terms as Perl itself.
 716
 717 =cut
 718
 719 1;