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