File Coverage

blib/lib/HTML/Mason/CGIHandler.pm

Criterion	Covered	Total	%
statement	97	116	83.6
branch	16	34	47.0
condition	5	20	25.0
subroutine	24	27	88.8
pod	5	5	100.0
total	147	202	72.7

package HTML::Mason::CGIHandler;
$HTML::Mason::CGIHandler::VERSION = '1.60';
use strict;
use warnings;

use HTML::Mason;
use HTML::Mason::Utils;
use CGI 2.46;
use File::Spec;
use Params::Validate qw(:all);
use HTML::Mason::Exceptions;
use HTML::Mason::FakeApache;

use Class::Container;
use base qw(Class::Container);

use HTML::Mason::MethodMaker
    ( read_write => [ qw( interp ) ] );

__PACKAGE__->valid_params
    (
     interp => { isa => 'HTML::Mason::Interp' },
    );

__PACKAGE__->contained_objects
    (
     interp => 'HTML::Mason::Interp',
     cgi_request => { class   => 'HTML::Mason::FakeApache', # $r
                      delayed => 1 },
    );


sub new {
    my $package = shift;

    my %p = @_;
    my $self = $package->SUPER::new(comp_root => $ENV{DOCUMENT_ROOT},
                                    request_class => 'HTML::Mason::Request::CGI',
                                    error_mode => 'output',
                                    error_format => 'html',
                                    %p);

    $self->{has_custom_out_method} = $p{out_method} ? 1 : 0;

    $self->interp->compiler->add_allowed_globals('$r');

    return $self;
}

sub handle_request {
    my $self = shift;
    $self->_handler( { comp => $ENV{PATH_INFO} }, @_ );
}

sub handle_comp {
    my ($self, $comp) = (shift, shift);
    $self->_handler( { comp => $comp }, @_ );
}

sub handle_cgi_object {
    my ($self, $cgi) = (shift, shift);
    $self->_handler( { comp => $cgi->path_info,
                       cgi       => $cgi },
                     @_);
}

sub _handler {
    my ($self, $p) = (shift, shift);

    my $r = $self->create_delayed_object('cgi_request', cgi => $p->{cgi});
    $self->interp->set_global('$r', $r);

    # hack for testing
    if (@_) {
        $self->{output} = '';
        $self->interp->out_method( \$self->{output} );
    } elsif (! $self->{has_custom_out_method}) {
        my $sent_headers = 0;

        my $out_method = sub {
            # Send headers if they have not been sent by us or by user.
            # We use instance here because if we store $request we get a
            # circular reference and a big memory leak.
            if (!$sent_headers and HTML::Mason::Request->instance->auto_send_headers) {
                $r->send_http_header();
                $sent_headers = 1;
            }

            # We could perhaps install a new, faster out_method here that
            # wouldn't have to keep checking whether headers have been
            # sent and what the $r->method is.  That would require
            # additions to the Request interface, though.

            print STDOUT grep {defined} @_;
        };

        $self->interp->out_method($out_method);
    }

    $self->interp->delayed_object_params('request', cgi_request => $r);

    my %args = $self->request_args($r);

    my @result;
    if (wantarray) {
        @result = eval { $self->interp->exec($p->{comp}, %args) };
    } elsif ( defined wantarray ) {
        $result[0] = eval { $self->interp->exec($p->{comp}, %args) };
    } else {
        eval { $self->interp->exec($p->{comp}, %args) };
    }

    if (my $err = $@) {
        my $retval = isa_mason_exception($err, 'Abort')   ? $err->aborted_value  :
                     isa_mason_exception($err, 'Decline') ? $err->declined_value :
                     rethrow_exception $err;

        # Unlike under mod_perl, we cannot simply return a 301 or 302
        # status and let Apache send headers, we need to explicitly
        # send this header ourself.
        $r->send_http_header if $retval && grep { $retval eq $_ } ( 200, 301, 302 );

        return $retval;
    }

    if (@_) {
        # This is a secret feature, and should stay secret (or go
        # away) because it's just a hack for the test suite.
        $_[0] .= $r->http_header . $self->{output};
    }

    return wantarray ? @result : defined wantarray ? $result[0] : undef;
}

# This is broken out in order to make subclassing easier.
sub request_args {
    my ($self, $r) = @_;

    return $r->params;
}


###########################################################
package HTML::Mason::Request::CGI;
# Subclass for HTML::Mason::Request object $m
$HTML::Mason::Request::CGI::VERSION = '1.60';
use HTML::Mason::Exceptions;
use HTML::Mason::Request;
use base qw(HTML::Mason::Request);

use Params::Validate qw(BOOLEAN);
Params::Validate::validation_options( on_fail => sub { param_error( join '', @_ ) } );

__PACKAGE__->valid_params
    ( cgi_request => { isa => 'HTML::Mason::FakeApache' },

      auto_send_headers => { parse => 'boolean', type => BOOLEAN, default => 1,
                             descr => "Whether HTTP headers should be auto-generated" },
    );

use HTML::Mason::MethodMaker
    ( read_only  => [ 'cgi_request' ],
      read_write => [ 'auto_send_headers' ] );

sub cgi_object {
    my $self = shift;
    return $self->{cgi_request}->query(@_);
}

#
# Override this method to send HTTP headers if necessary.
#
sub exec
{
    my $self = shift;
    my $r = $self->cgi_request;
    my $retval;

    eval { $retval = $self->SUPER::exec(@_) };

    if (my $err = $@)
    {
    $retval = isa_mason_exception($err, 'Abort')   ? $err->aborted_value  :
                  isa_mason_exception($err, 'Decline') ? $err->declined_value :
                  rethrow_exception $err;
    }

    # On a success code, send headers if they have not been sent and
    # if we are the top-level request. Since the out_method sends
    # headers, this will typically only apply after $m->abort.
    if (!$self->is_subrequest
        and $self->auto_send_headers
        and !$r->http_header_sent
        and (!$retval or $retval==200)) {
        $r->send_http_header();
    }

    return $retval;
}

sub redirect {
    my $self = shift;
    my $url = shift;
    my $status = shift || 302;

    $self->clear_buffer;

    $self->{cgi_request}->header_out( Location => $url );
    $self->{cgi_request}->header_out( Status => $status );

    $self->abort;
}

1;
__END__