File Coverage

lib/Test/WWW/Mechanize/CGIApp.pm

Criterion	Covered	Total	%
statement	49	61	80.3
branch	17	24	70.8
condition	1	3	33.3
subroutine	9	9	100.0
pod	2	2	100.0
total	78	99	78.7

package Test::WWW::Mechanize::CGIApp;

use strict;
use warnings;

# TODO use Test::WWW::Mechanize;
use base 'Test::WWW::Mechanize';

use HTTP::Request::AsCGI;

our $VERSION = "0.05";

sub new {
  my ($class, %cnf) = @_;
  my $self;
  my $app;

  if (exists($cnf{app})) {
    $app = delete $cnf{app};
  }

  $self = $class->SUPER::new(%cnf);

  $self->app( $app ) if ($app);
  return $self;
}

sub app {
  my $self = shift;

  if (@_) {
    $self->{_app} = shift;
  }
  return $self->{_app};
}

# copied from Test::WWW:Mechanize::Catalyst and slightly localized.
sub _make_request {
    my ( $self, $request ) = @_;
    $request = _cleanup_request($request);
    $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;

    my $response = $self->_do_request( $request );

    $response->header( 'Content-Base', $request->uri );
    $response->request($request);
    $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;

    # check if that was a redirect
    if (   $response->header('Location')
        && $self->redirect_ok( $request, $response ) )
      {

        # remember the old response
        my $old_response = $response;

        # *where* do they want us to redirect to?
        my $location = $old_response->header('Location');

        # no-one *should* be returning non-absolute URLs, but if they
        # are then we'd better cope with it.  Let's create a new URI, using
        # our request as the base.
        my $uri = URI->new_abs( $location, $request->uri )->as_string;

        # make a new response, and save the old response in it
        $response = $self->_make_request( HTTP::Request->new( GET => $uri ) );
        my $end_of_chain = $response;
        while ( $end_of_chain->previous )    # keep going till the end
	  {
            $end_of_chain = $end_of_chain->previous;
	  }                                          #   of the chain...
        $end_of_chain->previous($old_response);    # ...and add us to it
      }

    return $response;
  }

sub _cleanup_request {
  my $request = shift;

  $request->uri('http://localhost' . $request->uri())
    unless ( $request->uri() =~ m|^http| );

  return($request);
}

sub _do_request {
  my $self = shift;
  my $request = shift;

  my $cgi = HTTP::Request::AsCGI->new($request, %ENV)->setup;
  my $app = $self->app();

  if (defined ($app)) {
    if (ref $app) {
      if (ref $app eq 'CODE') {
	&{$app};
      }
      else {
	die "The app value is a ref to something that isn't implemented.";
      }
    }
    else {
      # use eval since the module name isn't a BAREWORD
      eval "require " . $app;

      if ($app->isa("CGI::Application::Dispatch")) {
	$app->dispatch();
      }
      elsif ($app->isa("CGI::Application")) {
	my $app = $app->new();
	$app->run();
      }
      else {
	die "Unable to use the value of app.";
      }
    }
  }
  else {
    die "App was not defined.";
  }

  return $cgi->restore->response;
}


1;

__END__