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