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
 485     if ( $c->debug && keys %{ $c->req->params } ) {
 486         my @params;
 487         for my $key ( keys %{ $c->req->params } ) {
 488             my $value = $c->req->params->{$key} || '';
 489             push @params, "$key=$value";
 490         }
 491         $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
 492     }
 493     $c->prepare_uploads;
 494     return $c;
 495 }
 496
 497 =head3 prepare_action
 498
 499 Prepare action.
 500
 501 =cut
 502
 503 sub prepare_action {
 504     my $c    = shift;
 505     my $path = $c->req->path;
 506     my @path = split /\//, $c->req->path;
 507     $c->req->args( \my @args );
 508     while (@path) {
 509         $path = join '/', @path;
 510         if ( my $result = $c->action($path) ) {
 511
 512             # It's a regex
 513             if ($#$result) {
 514                 my $match    = $result->[1];
 515                 my @snippets = @{ $result->[2] };
 516                 $c->log->debug(qq/Requested action "$path" matched "$match"/)
 517                   if $c->debug;
 518                 $c->log->debug(
 519                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 520                   if ( $c->debug && @snippets );
 521                 $c->req->action($match);
 522                 $c->req->snippets( \@snippets );
 523             }
 524             else {
 525                 $c->req->action($path);
 526                 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
 527             }
 528             $c->req->match($path);
 529             last;
 530         }
 531         unshift @args, pop @path;
 532     }
 533     unless ( $c->req->action ) {
 534         my $prefix = $c->req->args->[0];
 535         if ( $prefix && $c->actions->{plain}->{"\!$prefix/default"} ) {
 536             $c->req->match('');
 537             $c->req->action("\!$prefix/default");
 538             $c->log->debug('Using prefixed default action') if $c->debug;
 539         }
 540         elsif ( $c->actions->{plain}->{'!default'} ) {
 541             $c->req->match('');
 542             $c->req->action('!default');
 543             $c->log->debug('Using default action') if $c->debug;
 544         }
 545     }
 546     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 547       if ( $c->debug && @args );
 548 }
 549
 550 =head3 prepare_cookies;
 551
 552 Prepare cookies.
 553
 554 =cut
 555
 556 sub prepare_cookies { }
 557
 558 =head3 prepare_headers
 559
 560 Prepare headers.
 561
 562 =cut
 563
 564 sub prepare_headers { }
 565
 566 =head3 prepare_parameters
 567
 568 Prepare parameters.
 569
 570 =cut
 571
 572 sub prepare_parameters { }
 573
 574 =head3 prepare_path
 575
 576 Prepare path and base.
 577
 578 =cut
 579
 580 sub prepare_path { }
 581
 582 =head3 prepare_request
 583
 584 Prepare the engine request.
 585
 586 =cut
 587
 588 sub prepare_request { }
 589
 590 =head3 prepare_uploads
 591
 592 Prepare uploads.
 593
 594 =cut
 595
 596 sub prepare_uploads { }
 597
 598 =head3 process
 599
 600 Process a coderef in given class and catch exceptions.
 601 Errors are available via $c->errors.
 602
 603 =cut
 604
 605 sub process {
 606     my ( $c, $class, $code ) = @_;
 607     my $status;
 608     eval {
 609         if ( $c->debug )
 610         {
 611             my $action = $c->actions->{reverse}->{"$code"} || "$code";
 612             my $elapsed;
 613             ( $elapsed, $status ) =
 614               $c->benchmark( $code, $class, $c, @{ $c->req->args } );
 615             $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
 616               if $c->debug;
 617         }
 618         else { $status = &$code( $class, $c, @{ $c->req->args } ) }
 619     };
 620     if ( my $error = $@ ) {
 621         chomp $error;
 622         $error = qq/Caught exception "$error"/;
 623         $c->log->error($error);
 624         $c->errors($error) if $c->debug;
 625         return 0;
 626     }
 627     return $status;
 628 }
 629
 630 =head3 remove_action
 631
 632 Remove an action.
 633
 634     $c->remove_action('!foo');
 635
 636 =cut
 637
 638 sub remove_action {
 639     my ( $self, $action ) = @_;
 640     if ( delete $self->actions->{regex}->{$action} ) {
 641         while ( my ( $regex, $name ) = each %{ $self->actions->{compiled} } ) {
 642             if ( $name eq $action ) {
 643                 delete $self->actions->{compiled}->{$regex};
 644                 last;
 645             }
 646         }
 647     }
 648     else {
 649         delete $self->actions->{plain}->{$action};
 650     }
 651 }
 652
 653 =head3 request (req)
 654
 655 Returns a C<Catalyst::Request> object.
 656
 657     my $req = $c->req;
 658
 659 =head3 response (res)
 660
 661 Returns a C<Catalyst::Response> object.
 662
 663     my $res = $c->res;
 664
 665 =head3 setup
 666
 667 Setup.
 668
 669     MyApp->setup;
 670
 671 =cut
 672
 673 sub setup {
 674     my $self = shift;
 675     $self->setup_components;
 676     if ( $self->debug ) {
 677         my $name = $self->config->{name} || 'Application';
 678         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 679     }
 680 }
 681
 682 =head3 setup_components
 683
 684 Setup components.
 685
 686 =cut
 687
 688 sub setup_components {
 689     my $self = shift;
 690
 691     # Components
 692     my $class = ref $self || $self;
 693     eval <<"";
 694         package $class;
 695         import Module::Pluggable::Fast
 696           name   => '_components',
 697           search => [
 698             '$class\::Controller', '$class\::C',
 699             '$class\::Model',      '$class\::M',
 700             '$class\::View',       '$class\::V'
 701           ];
 702
 703     if ( my $error = $@ ) {
 704         chomp $error;
 705         $self->log->error(
 706             qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
 707     }
 708     $self->components( {} );
 709     for my $component ( $self->_components($self) ) {
 710         $self->components->{ ref $component } = $component;
 711     }
 712     $self->log->debug( 'Initialized components "'
 713           . join( ' ', keys %{ $self->components } )
 714           . '"' )
 715       if $self->debug;
 716 }
 717
 718 =head3 stash
 719
 720 Returns a hashref containing all your data.
 721
 722     $c->stash->{foo} ||= 'yada';
 723     print $c->stash->{foo};
 724
 725 =cut
 726
 727 sub stash {
 728     my $self = shift;
 729     if ( $_[0] ) {
 730         my $stash = $_[1] ? {@_} : $_[0];
 731         while ( my ( $key, $val ) = each %$stash ) {
 732             $self->{stash}->{$key} = $val;
 733         }
 734     }
 735     return $self->{stash};
 736 }
 737
 738 sub _prefix {
 739     my ( $class, $name ) = @_;
 740     my $prefix = _class2prefix($class);
 741     $name = "$prefix/$name" if $prefix;
 742     return $name;
 743 }
 744
 745 sub _class2prefix {
 746     my $class = shift;
 747     $class =~ /^.*::[(M)(Model)(V)(View)(C)(Controller)]+::(.*)$/;
 748     my $prefix = lc $1 || '';
 749     $prefix =~ s/\:\:/_/g;
 750     return $prefix;
 751 }
 752
 753 =head1 AUTHOR
 754
 755 Sebastian Riedel, C<sri@cpan.org>
 756
 757 =head1 COPYRIGHT
 758
 759 This program is free software, you can redistribute it and/or modify it under
 760 the same terms as Perl itself.
 761
 762 =cut
 763
 764 1;