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