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