File Coverage

blib/lib/Plack/App/FakeApache.pm

Criterion	Covered	Total	%
statement	31	33	93.9
branch			n/a
condition			n/a
subroutine	11	11	100.0
pod			n/a
total	42	44	95.4

package Plack::App::FakeApache;

use strict;
use warnings;

use Plack::Util;
use Plack::Util::Accessor qw( authen_handler authz_handler response_handler handler dir_config root logger request_args request_class);
use CGI::Emulate::PSGI;

use parent qw( Plack::Component );
use attributes;

use Carp;
use Module::Load;
use Scalar::Util qw( blessed );
use Apache2::Const qw(OK DECLINED HTTP_OK HTTP_UNAUTHORIZED HTTP_NOT_FOUND);

our $VERSION = 0.05;

sub _get_phase_handlers
{
    my $self = shift;
    my $phase = shift;
    my $accessor = $phase.'_handler';
    my $handlers = $self->$accessor or return;
    return @{$handlers};
}

# RUN_FIRST
# Run until a handler returns something other than DECLINED...
sub _run_first
{
    my $self = shift;
    my $phase = shift;
    my $fake_req = shift;
    my $fallback_status = shift;


	# NOTE.  I don't think this will mess people around who don't use
	# CGI, but if it does this could be conditionally applied with a
	# boolean $fake_req->shim_cgi_brain_damage or something.

	# Mangle env to cope with certain kinds of CGI brain damage.
	my $env = $fake_req->plack_request->env;
	local %ENV = (%ENV, CGI::Emulate::PSGI->emulate_environment($env));
	# and stdin!
	local *STDIN  = $env->{'psgi.input'};


    my $status = OK;
    foreach my $handler ($self->_get_phase_handlers($phase))
    {
        $status = $handler->($fake_req);
        last if $status != DECLINED;
    }
    return (defined($status) and $status != DECLINED) ? $status : $fallback_status; # mod_perl seems to do this if all handlers decline
}

sub call {
    my ($self, $env) = @_;

    my %args = (
        env => $env,
        dir_config => $self->dir_config,
        request_class => $self->request_class || 'Plack::App::FakeApache::Request',
        %{$self->request_args || {}}
    );

    $args{root} = $self->root if defined $self->root;

    if ( $self->logger ) {
        my $logger  = $self->logger;
        $args{log} = $logger if blessed($logger) and !$logger->isa('IO::Handle');
        $args{log} ||= Plack::FakeApache::Log->new( logger => sub { print $logger @_ } );
    }
    my $request_class = $args{request_class};
    my $fake_req = $request_class->new(%args);

    my $status = $self->_run_handlers($fake_req);

    $fake_req->status($status == OK ? HTTP_OK : $status);
    return $fake_req->finalize;
}

sub _run_handlers
{
    my $self = shift;
    my $fake_req = shift;
    my $status;

    # TODO: More request phases here...

    $status = $self->_run_first('authen', $fake_req, HTTP_UNAUTHORIZED);
    return $status if $status != OK;

    $status = $self->_run_first('authz', $fake_req, HTTP_UNAUTHORIZED);
    return $status if $status != OK;

    # we wrap the call to $handler->( ... ) in tie statements so
    # prints, etc are caught and sent to the right place
    tie *STDOUT, "Plack::App::FakeApache::Tie", $fake_req;
    $status = $self->_run_first('response', $fake_req, HTTP_NOT_FOUND);
    untie *STDOUT;
    return $status if $status != OK;

    # TODO: More request phases here...

    return OK;
}

sub prepare_app {
    my $self = shift;
    my $request_class = $self->request_class || 'Plack::App::FakeApache::Request';
    load $request_class;

    $self->response_handler($self->response_handler || $self->handler);

    foreach my $accessor ( qw(authen_handler authz_handler response_handler) )
    {
        my $handlers = $self->$accessor or next;
        my @handlers = ref($handlers) eq 'ARRAY' ? @{$handlers} : ($handlers);
        @handlers = map({ $self->_massage_handler($_) } @handlers);
        $self->$accessor([ @handlers ]);
    }

    carp "handler or response_handler not defined" unless $self->response_handler;

    # Workaround for mod_perl handlers doing CGI->new($r). CGI doesn't
    # know our fake request class, so we hijack CGI->new() and explicitly
    # pass the request query string instead...
    my $new = CGI->can('new');
    no warnings qw(redefine);
    *CGI::new = sub {
        my $request_class = $self->request_class || 'Plack::App::FakeApache::Request';

        if (blessed($_[1]) and $_[1]->isa($request_class)) {
            return $new->(CGI => $_[1]->env->{QUERY_STRING} || $_[1]->plack_request->content);
        }
        return $new->(@_);
    };

    return;
}

sub _massage_handler
{
    my $self = shift;
    my $handler = shift;
    my ($class, $method);
    if ( blessed $handler ) {
        $handler = sub { $handler->handler( @_ ) };
    } elsif ( my ($class, $method) = $handler =~ m/(.+)->(.+)/ ) {
        Plack::Util::load_class( $class );
        $handler = sub { $class->$method( @_ ) };
    } else {
        my $class  = $handler;
        Plack::Util::load_class( $class );
        my $method = eval { $class->can("handler") };
        if ( grep { $_ eq 'method' } attributes::get($method) ) {
            $handler = sub { $class->handler( @_ ) };
        } else {
            $handler = $method;
        }
    }
    return $handler;
}

package Plack::App::FakeApache::Tie;

sub TIEHANDLE {
    my $class = shift;
    my $r = shift;
    return bless \$r, $class;
}

sub PRINT  { my $r = ${ shift() }; $r->print(@_) }
sub WRITE  { my $r = ${ shift() }; $r->write(@_) }

1;

__END__