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