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