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