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