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