view release on metacpan or  search on metacpan

lib/Apache2/Controller.pm  view on Meta::CPAN

correct decisions to rely on open-source software.

You deploy the same Apache, the
same CPAN modules and your whole application package to every server,
and attach a url-generating subroutine to the L<Template|Template> stash
that puts in a different hostname when the URI is one of your
load-intensive functions.  

 <a href="[% myurl('/easy') %]">easy</a> "http://pony.x.y/easy"

 <a href="[% myurl('/hard') %]">hard</a> "http://packhorse.x.y/hard"

Web designers can be taught to use this function C<< myurl() >>, 
but system admins
maintain the map that it loads to figure out what servers to use.

Then the Apache2 config files on those
packhorse servers would pre-load only the subclassed controllers
that you needed, and redirect all other uri requests to the pony servers.

=cut

use strict;
use warnings FATAL => 'all';
use English '-no_match_vars';

use base qw( Apache2::Controller::Methods );

use Readonly;
use Scalar::Util qw( blessed );
use Log::Log4perl qw(:easy);

use YAML::Syck;
use Digest::SHA qw( sha224_base64 );
use URI;
use HTTP::Status qw( status_message );
use Scalar::Util qw( looks_like_number );

use Apache2::Controller::X;
use Apache2::Controller::Funk qw( log_bad_request_reason );

use Apache2::Request;
use Apache2::RequestRec ();
use Apache2::RequestIO ();
use Apache2::RequestUtil ();
use Apache2::Log;
use Apache2::Const -compile => qw( :common :http );

=head1 FUNCTIONS

=head2 a2c_new

 $handler = MyApp::C::ControllerSubclass->a2c_new( Apache2::RequestRec object )

This is called by handler() to create the Apache2::Controller object
via the module chosen by your L<Apache2::Controller::Dispatch> subclass.

We use C<< a2c_new >> instead of the conventional C<< new >>
because, in case you want to suck in the L<Apache2::Request>
methods with that module's automagic, then you don't get
confused about how C<<SUPER::>> behaves.  Otherwise you
get into a mess of keeping track of the order of bases
so you don't call C<< Apache2::Request->new() >> by accident,
which breaks everything.

=head3 subclassing C<a2c_new()>

To set params for the L<Apache2::Request> object,
you have to subclass C<a2c_new()>.

 package MyApp::ControllerBase;
 use base qw( Apache2::Controller Apache2::Request );

 sub a2c_new {
     my ($class, $r) = @_;
     return SUPER::new(
         $class, $r,
         POST_MAX => 65_535,
         TEMP_DIR => '/dev/shm',
     );
     # $self is already blessed in the class hierarchy
 }

 package MyApp::Controller::SomeURI;
 use base qw( MyApp::ControllerBase );
 sub allowed_methods qw( uri_one uri_two );
 sub uri_one { # ...

If you need to do the same stuff every time a request
starts, you can override the constructor through a
class hierarchy.

 package MyApp::ControllerBase;
 use base qw( Apache2::Controller Apache2::Request );

 sub new {
     my ($class, $r, @apr_override_args) = @_;
     my $self = SUPER::new(
         $class, $r,
         POST_MAX => 65_535,
         TEMP_DIR => '/dev/shm',
         @apr_override_args,
     );

     # $self is already blessed in the class hierarchy

     # do request-startup stuff common to all controller modules

     return $self;
 }

 package MyApp::Controller::SomeURI;
 use base qw( MyApp::ControllerBase );
 sub allowed_methods qw( uri_one uri_two );
 sub new {
     my ($class, $r) = @_;

     my $self = SUPER::a2c_new(
        $class, $r,
     );

     # no need to bless, A2C blesses into the child class

     # do request-startup stuff for this specific controller

     return $self;
 }

 sub uri_one {
     my ($self) = @_;
     $self->content_type('image/gif');
     # ...
     return Apache2::Const::HTTP_OK;
 }
 sub uri_two { # ...

Similarly, to do something always at the end of every 
request, from within the dispatched PerlResponseHandler:

 package MyApp::Controller::SomeURI;
 use Devel::Size;
 use Log::Log4perl qw(:easy);
 my $MAX = 40 * 1024 * 1024;
 sub DESTROY {
     my ($self) = @_;
     my $size = total_size($self);  # whoo baby!
     INFO("size of $self->{class} is bigger than $MAX!") if $size > $MAX;
     return; # self is destroyed
 }

See L<USING INHERITANCE> below for more tips.

=cut

my %temp_dirs  = ( );
my %post_maxes = ( );

sub a2c_new {
    my ($class, $r, @apr_opts) = @_;

    DEBUG sub {
        "new $class, reqrec is '$r', apr_opts:\n".Dump(\@apr_opts)
    };

    my $self = {
        class       => $class,
    };

    bless $self, $class;

    DEBUG "creating Apache2::Request object";
    my $req = Apache2::Request->new( $r, @apr_opts );
    DEBUG "request object is '$req'";

    $self->{r} = $req;  # for Apache2::Request subclass automagic

    my $pnotes_a2c = $req->pnotes->{a2c} || { };