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