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_cookies;
 424     $c->prepare_connection;
 425
 426     my $method   = $c->req->method   || '';
 427     my $path     = $c->req->path     || '';
 428     my $hostname = $c->req->hostname || '';
 429     my $address  = $c->req->address  || '';
 430     $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
 431       if $c->debug;
 432
 433     $c->prepare_action;
 434     $c->prepare_parameters;
 435
 436     if ( $c->debug && keys %{ $c->req->params } ) {
 437         my $t = Text::ASCIITable->new;
 438         $t->setCols( 'Key', 'Value' );
 439         $t->setColWidth( 'Key',   37, 1 );
 440         $t->setColWidth( 'Value', 36, 1 );
 441         for my $key ( keys %{ $c->req->params } ) {
 442             my $value = $c->req->params->{$key} || '';
 443             $t->addRow( $key, $value );
 444         }
 445         $c->log->debug( 'Parameters are', $t->draw );
 446     }
 447
 448     $c->prepare_uploads;
 449     return $c;
 450 }
 451
 452 =item $c->prepare_action
 453
 454 Prepare action.
 455
 456 =cut
 457
 458 sub prepare_action {
 459     my $c    = shift;
 460     my $path = $c->req->path;
 461     my @path = split /\//, $c->req->path;
 462     $c->req->args( \my @args );
 463
 464     while (@path) {
 465         $path = join '/', @path;
 466         if ( my $result = ${ $c->get_action($path) }[0] ) {
 467
 468             # It's a regex
 469             if ($#$result) {
 470                 my $match    = $result->[1];
 471                 my @snippets = @{ $result->[2] };
 472                 $c->log->debug(
 473                     qq/Requested action is "$path" and matched "$match"/)
 474                   if $c->debug;
 475                 $c->log->debug(
 476                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 477                   if ( $c->debug && @snippets );
 478                 $c->req->action($match);
 479                 $c->req->snippets( \@snippets );
 480             }
 481
 482             else {
 483                 $c->req->action($path);
 484                 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
 485             }
 486
 487             $c->req->match($path);
 488             last;
 489         }
 490         unshift @args, pop @path;
 491     }
 492
 493     unless ( $c->req->action ) {
 494         $c->req->action('default');
 495         $c->req->match('');
 496     }
 497
 498     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 499       if ( $c->debug && @args );
 500 }
 501
 502 =item $c->prepare_connection
 503
 504 Prepare connection.
 505
 506 =cut
 507
 508 sub prepare_connection { }
 509
 510 =item $c->prepare_cookies
 511
 512 Prepare cookies.
 513
 514 =cut
 515
 516 sub prepare_cookies {
 517     my $c = shift;
 518
 519     if ( my $header = $c->request->header('Cookie') ) {
 520         $c->req->cookies( { CGI::Cookie->parse($header) } );
 521     }
 522 }
 523
 524 =item $c->prepare_headers
 525
 526 Prepare headers.
 527
 528 =cut
 529
 530 sub prepare_headers { }
 531
 532 =item $c->prepare_parameters
 533
 534 Prepare parameters.
 535
 536 =cut
 537
 538 sub prepare_parameters { }
 539
 540 =item $c->prepare_path
 541
 542 Prepare path and base.
 543
 544 =cut
 545
 546 sub prepare_path { }
 547
 548 =item $c->prepare_request
 549
 550 Prepare the engine request.
 551
 552 =cut
 553
 554 sub prepare_request { }
 555
 556 =item $c->prepare_uploads
 557
 558 Prepare uploads.
 559
 560 =cut
 561
 562 sub prepare_uploads { }
 563
 564 =item $c->run
 565
 566 Starts the engine.
 567
 568 =cut
 569
 570 sub run { }
 571
 572 =item $c->request
 573
 574 =item $c->req
 575
 576 Returns a C<Catalyst::Request> object.
 577
 578     my $req = $c->req;
 579
 580 =item $c->response
 581
 582 =item $c->res
 583
 584 Returns a C<Catalyst::Response> object.
 585
 586     my $res = $c->res;
 587
 588 =item $class->setup
 589
 590 Setup.
 591
 592     MyApp->setup;
 593
 594 =cut
 595
 596 sub setup {
 597     my $self = shift;
 598     $self->setup_components;
 599     if ( $self->debug ) {
 600         my $name = $self->config->{name} || 'Application';
 601         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 602     }
 603 }
 604
 605 =item $class->setup_components
 606
 607 Setup components.
 608
 609 =cut
 610
 611 sub setup_components {
 612     my $self = shift;
 613
 614     # Components
 615     my $class = ref $self || $self;
 616     eval <<"";
 617         package $class;
 618         import Module::Pluggable::Fast
 619           name   => '_components',
 620           search => [
 621             '$class\::Controller', '$class\::C',
 622             '$class\::Model',      '$class\::M',
 623             '$class\::View',       '$class\::V'
 624           ];
 625
 626     if ( my $error = $@ ) {
 627         chomp $error;
 628         die qq/Couldn't load components "$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 # Takes a coderef and returns an arrayref containing attributes
 673 sub _get_attrs { attributes::get( $_[0] ) || [] }
 674
 675 =back
 676
 677 =head1 AUTHOR
 678
 679 Sebastian Riedel, C<sri@cpan.org>
 680
 681 =head1 COPYRIGHT
 682
 683 This program is free software, you can redistribute it and/or modify it under
 684 the same terms as Perl itself.
 685
 686 =cut
 687
 688 1;