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