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