lib/Catalyst/Engine.pm

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