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