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