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