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             for my $regex ( keys %{ $self->actions->{compiled} } ) {
  98                 my $name = $self->actions->{compiled}->{$regex};
  99                 if ( $action =~ $regex ) {
 100                     my @snippets;
 101                     for my $i ( 1 .. 9 ) {
 102                         no strict 'refs';
 103                         last unless ${$i};
 104                         push @snippets, ${$i};
 105                     }
 106                     return [ $self->actions->{regex}->{$name},
 107                         $name, \@snippets ];
 108                 }
 109             }
 110         }
 111         return 0;
 112     }
 113     else {
 114         return (
 115             keys %{ $self->actions->{plain} },
 116             keys %{ $self->actions->{regex} }
 117         );
 118     }
 119 }
 120
 121 =head3 benchmark
 122
 123 Takes a coderef with arguments and returns elapsed time as float.
 124
 125     my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
 126     $c->log->info( sprintf "Processing took %f seconds", $elapsed );
 127
 128 =cut
 129
 130 sub benchmark {
 131     my $c       = shift;
 132     my $code    = shift;
 133     my $time    = [gettimeofday];
 134     my @return  = &$code(@_);
 135     my $elapsed = tv_interval $time;
 136     return wantarray ? ( $elapsed, @return ) : $elapsed;
 137 }
 138
 139 =head3 component / comp
 140
 141 Get a component object by name.
 142
 143     $c->comp('MyApp::Model::MyModel')->do_stuff;
 144
 145 Regex search for a component.
 146
 147     $c->comp('mymodel')->do_stuff;
 148
 149 =cut
 150
 151 sub component {
 152     my ( $c, $name ) = @_;
 153     if ( my $component = $c->components->{$name} ) {
 154         return $component;
 155     }
 156     else {
 157         for my $component ( keys %{ $c->components } ) {
 158             return $c->components->{$component} if $component =~ /$name/i;
 159         }
 160     }
 161 }
 162
 163 =head3 errors
 164
 165 Returns an arrayref containing errors messages.
 166
 167     my @errors = @{ $c->errors };
 168
 169 Add a new error.
 170
 171     $c->errors('Something bad happened');
 172
 173 =cut
 174
 175 sub errors {
 176     my $c = shift;
 177     my $errors = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
 178     push @{ $c->{errors} }, @$errors;
 179     return $c->{errors};
 180 }
 181
 182 =head3 finalize
 183
 184 Finalize request.
 185
 186 =cut
 187
 188 sub finalize {
 189     my $c = shift;
 190     if ( !$c->res->output || $#{ $c->errors } >= 0 ) {
 191         $c->res->headers->content_type('text/html');
 192         my $name = $c->config->{name} || 'Catalyst Application';
 193         my ( $title, $errors, $infos );
 194         if ( $c->debug ) {
 195             $errors = join '<br/>', @{ $c->errors };
 196             $errors ||= 'No output';
 197             $title = $name = "$name on Catalyst $Catalyst::VERSION";
 198             my $req   = encode_entities Dumper $c->req;
 199             my $res   = encode_entities Dumper $c->res;
 200             my $stash = encode_entities Dumper $c->stash;
 201             $infos = <<"";
 202 <br/>
 203 <b><u>Request</u></b><br/>
 204 <pre>$req</pre>
 205 <b><u>Response</u></b><br/>
 206 <pre>$res</pre>
 207 <b><u>Stash</u></b><br/>
 208 <pre>$stash</pre>
 209
 210         }
 211         else {
 212             $title  = $name;
 213             $errors = '';
 214             $infos  = <<"";
 215 <pre>
 216 (en) Please come back later
 217 (de) Bitte versuchen sie es spaeter nocheinmal
 218 (nl) Gelieve te komen later terug
 219 (no) Vennligst prov igjen senere
 220 (fr) Veuillez revenir plus tard
 221 (es) Vuelto por favor mas adelante
 222 (pt) Voltado por favor mais tarde
 223 (it) Ritornato prego più successivamente
 224 </pre>
 225
 226             $name = '';
 227         }
 228         $c->res->{output} = <<"";
 229 <html>
 230     <head>
 231         <title>$title</title>
 232         <style type="text/css">
 233             body {
 234                 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 235                              Tahoma, Arial, helvetica, sans-serif;
 236                 color: #ddd;
 237                 background-color: #eee;
 238                 margin: 0px;
 239                 padding: 0px;
 240             }
 241             div.box {
 242                 background-color: #ccc;
 243                 border: 1px solid #aaa;
 244                 padding: 4px;
 245                 margin: 10px;
 246                 -moz-border-radius: 10px;
 247             }
 248             div.errors {
 249                 background-color: #977;
 250                 border: 1px solid #755;
 251                 padding: 8px;
 252                 margin: 4px;
 253                 margin-bottom: 10px;
 254                 -moz-border-radius: 10px;
 255             }
 256             div.infos {
 257                 background-color: #797;
 258                 border: 1px solid #575;
 259                 padding: 8px;
 260                 margin: 4px;
 261                 margin-bottom: 10px;
 262                 -moz-border-radius: 10px;
 263             }
 264             div.name {
 265                 background-color: #779;
 266                 border: 1px solid #557;
 267                 padding: 8px;
 268                 margin: 4px;
 269                 -moz-border-radius: 10px;
 270             }
 271         </style>
 272     </head>
 273     <body>
 274         <div class="box">
 275             <div class="errors">$errors</div>
 276             <div class="infos">$infos</div>
 277             <div class="name">$name</div>
 278         </div>
 279     </body>
 280 </html>
 281
 282     }
 283     if ( my $location = $c->res->redirect ) {
 284         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
 285         $c->res->headers->header( Location => $location );
 286         $c->res->status(302);
 287     }
 288     $c->res->headers->content_length( length $c->res->output );
 289     my $status = $c->finalize_headers;
 290     $c->finalize_output;
 291     return $status;
 292 }
 293
 294 =head3 finalize_headers
 295
 296 Finalize headers.
 297
 298 =cut
 299
 300 sub finalize_headers { }
 301
 302 =head3 finalize_output
 303
 304 Finalize output.
 305
 306 =cut
 307
 308 sub finalize_output { }
 309
 310 =head3 forward
 311
 312 Forward processing to a private/public action or a method from a class.
 313 If you define a class without method it will default to process().
 314
 315     $c->forward('!foo');
 316     $c->forward('index.html');
 317     $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
 318     $c->forward('MyApp::View::TT');
 319
 320 =cut
 321
 322 sub forward {
 323     my $c       = shift;
 324     my $command = shift;
 325     unless ($command) {
 326         $c->log->debug('Nothing to forward to') if $c->debug;
 327         return 0;
 328     }
 329     if ( $command =~ /^\?(.*)$/ ) {
 330         $command = $1;
 331         my $caller = caller(0);
 332         $command = _prefix( $caller, $command );
 333     }
 334     elsif ( $command =~ /^\!\?(.*)$/ ) {
 335         $command = $1;
 336         my $caller = caller(0);
 337         $command = _prefix( $caller, $command );
 338         $command = "\!$command";
 339     }
 340     elsif ( $command =~ /^\!(.*)$/ ) {
 341         my $try    = $1;
 342         my $caller = caller(0);
 343         my $prefix = _class2prefix($caller);
 344         $try = "!$prefix/$command";
 345         $command = $try if $c->actions->{plain}->{$try};
 346     }
 347     my ( $class, $code );
 348     if ( my $action = $c->action($command) ) {
 349         if ( $action->[2] ) {
 350             $c->log->debug(qq/Couldn't forward "$command" to regex action/)
 351               if $c->debug;
 352             return 0;
 353         }
 354         ( $class, $code ) = @{ $action->[0] };
 355     }
 356     else {
 357         $class = $command;
 358         if ( $class =~ /[^\w\:]/ ) {
 359             $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
 360             return 0;
 361         }
 362         my $method = shift || 'process';
 363         if ( $code = $class->can($method) ) {
 364             $c->actions->{reverse}->{"$code"} = "$class->$method";
 365         }
 366         else {
 367             $c->log->debug(qq/Couldn't forward to "$class->$method"/)
 368               if $c->debug;
 369             return 0;
 370         }
 371     }
 372     $class = $c->components->{$class} || $class;
 373     return $c->process( $class, $code );
 374 }
 375
 376 =head3 handler
 377
 378 Handles the request.
 379
 380 =cut
 381
 382 sub handler {
 383     my ( $class, $r ) = @_;
 384
 385     # Always expect worst case!
 386     my $status = -1;
 387     eval {
 388         my $handler = sub {
 389             my $c = $class->prepare($r);
 390             if ( my $action = $c->action( $c->req->action ) ) {
 391                 my ( $begin, $end );
 392                 my $class  = ${ $action->[0] }[0];
 393                 my $prefix = _class2prefix($class);
 394                 if ($prefix) {
 395                     if ( $c->actions->{plain}->{"\!$prefix/begin"} ) {
 396                         $begin = "\!$prefix/begin";
 397                     }
 398                     elsif ( $c->actions->{plain}->{'!begin'} ) {
 399                         $begin = '!begin';
 400                     }
 401                     if ( $c->actions->{plain}->{"\!$prefix/end"} ) {
 402                         $end = "\!$prefix/end";
 403                     }
 404                     elsif ( $c->actions->{plain}->{'!end'} ) { $end = '!end' }
 405                 }
 406                 else {
 407                     if ( $c->actions->{plain}->{'!begin'} ) {
 408                         $begin = '!begin';
 409                     }
 410                     if ( $c->actions->{plain}->{'!end'} ) { $end = '!end' }
 411                 }
 412                 $c->forward($begin)            if $begin;
 413                 $c->forward( $c->req->action ) if $c->req->action;
 414                 $c->forward($end)              if $end;
 415             }
 416             else {
 417                 my $action = $c->req->path;
 418                 my $error  = $action
 419                   ? qq/Unknown resource "$action"/
 420                   : "No default action defined";
 421                 $c->log->error($error) if $c->debug;
 422                 $c->errors($error);
 423             }
 424             return $c->finalize;
 425         };
 426         if ( $class->debug ) {
 427             my $elapsed;
 428             ( $elapsed, $status ) = $class->benchmark($handler);
 429             $elapsed = sprintf '%f', $elapsed;
 430             my $av = sprintf '%.3f', 1 / $elapsed;
 431             $class->log->info( "Request took $elapsed" . "s ($av/s)" );
 432         }
 433         else { $status = &$handler }
 434     };
 435     if ( my $error = $@ ) {
 436         chomp $error;
 437         $class->log->error(qq/Caught exception in engine "$error"/);
 438     }
 439     $COUNT++;
 440     return $status;
 441 }
 442
 443 =head3 prepare
 444
 445 Turns the request (Apache, CGI...) into a Catalyst context.
 446
 447 =cut
 448
 449 sub prepare {
 450     my ( $class, $r ) = @_;
 451     my $c = bless {
 452         request => Catalyst::Request->new(
 453             {
 454                 arguments  => [],
 455                 cookies    => {},
 456                 headers    => HTTP::Headers->new,
 457                 parameters => {},
 458                 snippets   => [],
 459                 uploads    => {}
 460             }
 461         ),
 462         response => Catalyst::Response->new(
 463             { cookies => {}, headers => HTTP::Headers->new, status => 200 }
 464         ),
 465         stash => {}
 466     }, $class;
 467     if ( $c->debug ) {
 468         my $secs = time - $START || 1;
 469         my $av = sprintf '%.3f', $COUNT / $secs;
 470         $c->log->debug('********************************');
 471         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 472         $c->log->debug('********************************');
 473         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 474     }
 475     $c->prepare_request($r);
 476     $c->prepare_path;
 477     $c->prepare_cookies;
 478     $c->prepare_headers;
 479     my $method = $c->req->method;
 480     my $path   = $c->req->path;
 481     $c->log->debug(qq/"$method" request for "$path"/) if $c->debug;
 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             last;
 521         }
 522         unshift @args, pop @path;
 523     }
 524     unless ( $c->req->action ) {
 525         my $prefix = $c->req->args->[0];
 526         if ( $prefix && $c->actions->{plain}->{"\!$prefix/default"} ) {
 527             $c->req->match('');
 528             $c->req->action("\!$prefix/default");
 529             $c->log->debug('Using prefixed default action') if $c->debug;
 530         }
 531         elsif ( $c->actions->{plain}->{'!default'} ) {
 532             $c->req->match('');
 533             $c->req->action('!default');
 534             $c->log->debug('Using default action') if $c->debug;
 535         }
 536     }
 537     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 538       if ( $c->debug && @args );
 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;