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