lib/Catalyst/Engine.pm

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