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 [ $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     my ( $class, $code );
 341     if ( my $action = $c->action($command) ) {
 342         ( $class, $code ) = @{ $action->[0] };
 343     }
 344     else {
 345         $class = $command;
 346         if ( $class =~ /[^\w\:]/ ) {
 347             $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
 348             return 0;
 349         }
 350         my $method = shift || 'process';
 351         if ( $code = $class->can($method) ) {
 352             $c->actions->{reverse}->{"$code"} = "$class->$method";
 353         }
 354         else {
 355             $c->log->debug(qq/Couldn't forward to "$class->$method"/)
 356               if $c->debug;
 357             return 0;
 358         }
 359     }
 360     $class = $c->components->{$class} || $class;
 361     return $c->process( $class, $code );
 362 }
 363
 364 =head3 handler
 365
 366 Handles the request.
 367
 368 =cut
 369
 370 sub handler {
 371     my ( $class, $r ) = @_;
 372
 373     # Always expect worst case!
 374     my $status = -1;
 375     eval {
 376         my $handler = sub {
 377             my $c = $class->prepare($r);
 378             if ( my $action = $c->action( $c->req->action ) ) {
 379                 my ( $begin, $end );
 380                 my $class  = ${ $action->[0] }[0];
 381                 my $prefix = _class2prefix($class);
 382                 if ($prefix) {
 383                     if ( $c->actions->{plain}->{"\!$prefix/begin"} ) {
 384                         $begin = "\!$prefix/begin";
 385                     }
 386                     elsif ( $c->actions->{plain}->{'!begin'} ) {
 387                         $begin = '!begin';
 388                     }
 389                     if ( $c->actions->{plain}->{"\!$prefix/end"} ) {
 390                         $end = "\!$prefix/end";
 391                     }
 392                     elsif ( $c->actions->{plain}->{'!end'} ) { $end = '!end' }
 393                 }
 394                 else {
 395                     if ( $c->actions->{plain}->{'!begin'} ) {
 396                         $begin = '!begin';
 397                     }
 398                     if ( $c->actions->{plain}->{'!end'} ) { $end = '!end' }
 399                 }
 400                 $c->forward($begin)            if $begin;
 401                 $c->forward( $c->req->action ) if $c->req->action;
 402                 $c->forward($end)              if $end;
 403             }
 404             else {
 405                 my $action = $c->req->path;
 406                 my $error  = $action
 407                   ? qq/Unknown resource "$action"/
 408                   : "No default action defined";
 409                 $c->log->error($error) if $c->debug;
 410                 $c->errors($error);
 411             }
 412             return $c->finalize;
 413         };
 414         if ( $class->debug ) {
 415             my $elapsed;
 416             ( $elapsed, $status ) = $class->benchmark($handler);
 417             $elapsed = sprintf '%f', $elapsed;
 418             my $av = sprintf '%.3f', 1 / $elapsed;
 419             $class->log->info( "Request took $elapsed" . "s ($av/s)" );
 420         }
 421         else { $status = &$handler }
 422     };
 423     if ( my $error = $@ ) {
 424         chomp $error;
 425         $class->log->error(qq/Caught exception in engine "$error"/);
 426     }
 427     $COUNT++;
 428     return $status;
 429 }
 430
 431 =head3 prepare
 432
 433 Turns the request (Apache, CGI...) into a Catalyst context.
 434
 435 =cut
 436
 437 sub prepare {
 438     my ( $class, $r ) = @_;
 439     my $c = bless {
 440         request => Catalyst::Request->new(
 441             {
 442                 arguments  => [],
 443                 cookies    => {},
 444                 headers    => HTTP::Headers->new,
 445                 parameters => {},
 446                 snippets   => [],
 447                 uploads    => {}
 448             }
 449         ),
 450         response => Catalyst::Response->new(
 451             { cookies => {}, headers => HTTP::Headers->new, status => 200 }
 452         ),
 453         stash => {}
 454     }, $class;
 455     if ( $c->debug ) {
 456         my $secs = time - $START || 1;
 457         my $av = sprintf '%.3f', $COUNT / $secs;
 458         $c->log->debug('********************************');
 459         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 460         $c->log->debug('********************************');
 461         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 462     }
 463     $c->prepare_request($r);
 464     $c->prepare_path;
 465     my $path = $c->request->path;
 466     $c->log->debug(qq/Requested path "$path"/) if $c->debug;
 467     $c->prepare_cookies;
 468     $c->prepare_headers;
 469     $c->prepare_action;
 470     $c->prepare_parameters;
 471     $c->prepare_uploads;
 472     return $c;
 473 }
 474
 475 =head3 prepare_action
 476
 477 Prepare action.
 478
 479 =cut
 480
 481 sub prepare_action {
 482     my $c    = shift;
 483     my $path = $c->req->path;
 484     my @path = split /\//, $c->req->path;
 485     $c->req->args( \my @args );
 486     while (@path) {
 487         $path = join '/', @path;
 488         if ( my $result = $c->action($path) ) {
 489
 490             # It's a regex
 491             if ($#$result) {
 492                 my $match    = $result->[0];
 493                 my @snippets = @{ $result->[1] };
 494                 $c->log->debug(qq/Requested action "$path" matched "$match"/)
 495                   if $c->debug;
 496                 $c->log->debug(
 497                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 498                   if ( $c->debug && @snippets );
 499                 $c->req->action($match);
 500                 $c->req->snippets( \@snippets );
 501             }
 502             else {
 503                 $c->req->action($path);
 504                 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
 505             }
 506             $c->req->match($path);
 507             $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 508               if ( $c->debug && @args );
 509             last;
 510         }
 511         unshift @args, pop @path;
 512     }
 513     unless ( $c->req->action ) {
 514         my $prefix = $c->req->args->[0];
 515         if ( $prefix && $c->actions->{plain}->{"\!$prefix/default"} ) {
 516             $c->req->match('');
 517             $c->req->action("\!$prefix/default");
 518             $c->log->debug('Using prefixed default action') if $c->debug;
 519         }
 520         elsif ( $c->actions->{plain}->{'!default'} ) {
 521             $c->req->match('');
 522             $c->req->action('!default');
 523             $c->log->debug('Using default action') if $c->debug;
 524         }
 525     }
 526 }
 527
 528 =head3 prepare_cookies;
 529
 530 Prepare cookies.
 531
 532 =cut
 533
 534 sub prepare_cookies { }
 535
 536 =head3 prepare_headers
 537
 538 Prepare headers.
 539
 540 =cut
 541
 542 sub prepare_headers { }
 543
 544 =head3 prepare_parameters
 545
 546 Prepare parameters.
 547
 548 =cut
 549
 550 sub prepare_parameters { }
 551
 552 =head3 prepare_path
 553
 554 Prepare path and base.
 555
 556 =cut
 557
 558 sub prepare_path { }
 559
 560 =head3 prepare_request
 561
 562 Prepare the engine request.
 563
 564 =cut
 565
 566 sub prepare_request { }
 567
 568 =head3 prepare_uploads
 569
 570 Prepare uploads.
 571
 572 =cut
 573
 574 sub prepare_uploads { }
 575
 576 =head3 process
 577
 578 Process a coderef in given class and catch exceptions.
 579 Errors are available via $c->errors.
 580
 581 =cut
 582
 583 sub process {
 584     my ( $c, $class, $code ) = @_;
 585     my $status;
 586     eval {
 587         if ( $c->debug )
 588         {
 589             my $action = $c->actions->{reverse}->{"$code"} || "$code";
 590             my $elapsed;
 591             ( $elapsed, $status ) =
 592               $c->benchmark( $code, $class, $c, @{ $c->req->args } );
 593             $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
 594               if $c->debug;
 595         }
 596         else { $status = &$code( $class, $c, @{ $c->req->args } ) }
 597     };
 598     if ( my $error = $@ ) {
 599         chomp $error;
 600         $error = qq/Caught exception "$error"/;
 601         $c->log->error($error);
 602         $c->errors($error) if $c->debug;
 603         return 0;
 604     }
 605     return $status;
 606 }
 607
 608 =head3 remove_action
 609
 610 Remove an action.
 611
 612     $c->remove_action('!foo');
 613
 614 =cut
 615
 616 sub remove_action {
 617     my ( $self, $action ) = @_;
 618     if ( delete $self->actions->{regex}->{$action} ) {
 619         while ( my ( $regex, $name ) = each %{ $self->actions->{compiled} } ) {
 620             if ( $name eq $action ) {
 621                 delete $self->actions->{compiled}->{$regex};
 622                 last;
 623             }
 624         }
 625     }
 626     else {
 627         delete $self->actions->{plain}->{$action};
 628     }
 629 }
 630
 631 =head3 request (req)
 632
 633 Returns a C<Catalyst::Request> object.
 634
 635     my $req = $c->req;
 636
 637 =head3 response (res)
 638
 639 Returns a C<Catalyst::Response> object.
 640
 641     my $res = $c->res;
 642
 643 =head3 setup
 644
 645 Setup.
 646
 647     MyApp->setup;
 648
 649 =cut
 650
 651 sub setup {
 652     my $self = shift;
 653     $self->setup_components;
 654     if ( $self->debug ) {
 655         my $name = $self->config->{name} || 'Application';
 656         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 657     }
 658 }
 659
 660 =head3 setup_components
 661
 662 Setup components.
 663
 664 =cut
 665
 666 sub setup_components {
 667     my $self = shift;
 668
 669     # Components
 670     my $class = ref $self || $self;
 671     eval <<"";
 672         package $class;
 673         import Module::Pluggable::Fast
 674           name   => '_components',
 675           search => [
 676             '$class\::Controller', '$class\::C',
 677             '$class\::Model',      '$class\::M',
 678             '$class\::View',       '$class\::V'
 679           ];
 680
 681     if ( my $error = $@ ) {
 682         chomp $error;
 683         $self->log->error(
 684             qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
 685     }
 686     $self->components( {} );
 687     for my $component ( $self->_components($self) ) {
 688         $self->components->{ ref $component } = $component;
 689     }
 690     $self->log->debug( 'Initialized components "'
 691           . join( ' ', keys %{ $self->components } )
 692           . '"' )
 693       if $self->debug;
 694 }
 695
 696 =head3 stash
 697
 698 Returns a hashref containing all your data.
 699
 700     $c->stash->{foo} ||= 'yada';
 701     print $c->stash->{foo};
 702
 703 =cut
 704
 705 sub stash {
 706     my $self = shift;
 707     if ( $_[0] ) {
 708         my $stash = $_[1] ? {@_} : $_[0];
 709         while ( my ( $key, $val ) = each %$stash ) {
 710             $self->{stash}->{$key} = $val;
 711         }
 712     }
 713     return $self->{stash};
 714 }
 715
 716 sub _prefix {
 717     my ( $class, $name ) = @_;
 718     my $prefix = _class2prefix($class);
 719     $name = "$prefix/$name" if $prefix;
 720     return $name;
 721 }
 722
 723 sub _class2prefix {
 724     my $class = shift;
 725     $class =~ /^.*::[(M)(Model)(V)(View)(C)(Controller)]+::(.*)$/;
 726     my $prefix = lc $1 || '';
 727     $prefix =~ s/\:\:/_/g;
 728     return $prefix;
 729 }
 730
 731 =head1 AUTHOR
 732
 733 Sebastian Riedel, C<sri@cpan.org>
 734
 735 =head1 COPYRIGHT
 736
 737 This program is free software, you can redistribute it and/or modify it under
 738 the same terms as Perl itself.
 739
 740 =cut
 741
 742 1;