view release on metacpan or  search on metacpan

lib/Apache/SWIT/Test.pm  view on Meta::CPAN

use strict;
use warnings FATAL => 'all';

package Apache::SWIT::Test::Mechanize;
use base 'WWW::Mechanize';
use Encode::Guess;

sub reload {
	my $self = shift;
	$self->get($self->uri);
}

sub redirect_ok {
	my $self = shift;
	return $self->max_redirect ? $self->SUPER::redirect_ok(@_) : undef;
}

package Apache2::Request;
sub new { return $_[1]; }

package Apache::SWIT::Test;
use base 'Class::Accessor', 'Class::Data::Inheritable';
use Apache::SWIT::Maker::Conversions;
use Apache::SWIT::Test::Utils;
use Apache::SWIT::Test::Request;
use HTML::Tested::Test;
use Test::More;
use Carp;
use Data::Dumper;
use File::Slurp;
use Apache::TestRequest;
use Encode;
use Apache::SWIT;

BEGIN {
	no strict 'refs';
	no warnings 'redefine';
	*{ "Apache::SWIT::swit_die" } = sub {
		my ($class, $msg, $r, @more) = @_;
		confess "$msg with request:\n" . $r->as_string . "and more:\n"
					. join("\n", map { Dumper($_) } @more);
	};
}

__PACKAGE__->mk_accessors(qw(mech session redirect_request));
__PACKAGE__->mk_classdata('root_location');

sub _Do_Startup {
	package main;
	local $0 = shift;
	do $0 or Carp::confess "# Unable to do $0\: $@";
}

=head1 METHODS

=cut
sub do_startup {
	_Do_Startup("blib/conf/startup.pl");
	_Do_Startup("blib/conf/do_swit_startups.pl");
}

sub new {
	my ($class, $args) = @_;
	$args ||= {};
	if ($ENV{SWIT_HAS_APACHE}) {
		$args->{mech} = Apache::SWIT::Test::Mechanize->new;
	}
	$args->{session} = $args->{session_class}->new;
	my $self = $class->SUPER::new($args);
	$self->root_location("") unless $self->root_location;
	$self->_setup_session(Apache::SWIT::Test::Request->new({
		uri => $self->root_location . "/" }), url_to_make => "");
	return $self;
}

sub new_guitest {
	my $self = shift()->new(@_);
	if ($self->mech) {
		$ENV{MOZ_NO_REMOTE} = 1;
		use IO::CaptureOutput qw(capture);
		{
			local $SIG{__WARN__} = sub {};
			eval "require X11::GUITest";
			die "Unable to use X11::GUITest: $@" if $@;
			X11::GUITest::InitGUITest();
		}
		capture(sub {
			eval "use Mozilla::Mechanize::GUITester";
		});
		confess "Unable to use Mozilla::Mechanize::GUITester: $@" if $@;
		my $m = Mozilla::Mechanize::GUITester->new(quiet => 1
				, visible => 0);
		$self->mech($m);
		$m->x_resize_window(800, 600);
	}
	return $self;
}

sub _setup_session {
	my ($self, $r, %a) = @_;
	$r->pnotes('SWITSession', $self->session);
	$self->session->{_request} = $r;
	$r->uri($a{base_url} || $self->root_location . "/" . $a{url_to_make});
}

sub _direct_render {
	my ($self, $handler_class, %args) = @_;
	my $uri = $self->_find_url_to_go(%args);
	my $r = ($self->redirect_request && !$uri) ? $self->redirect_request
			: Apache::SWIT::Test::Request->new;
	$self->redirect_request(undef);

	my $cp = $r->_param || {};
	$r->set_params($args{param}) if $args{param};
	$cp->{$_} = $r->param($_) for keys %{ $r->_param || {} };
	$r->_param($cp);

	$self->_setup_session($r, %args);
	my $res = $handler_class->swit_render($r);
	$r->run_cleanups;
	return $res;
}

sub _do_swit_update {
	my ($self, $handler_class, $r, %args) = @_;
	$self->_setup_session($r, %args);
	my @res = $handler_class->swit_update($r);
	my $new_r = Apache::SWIT::Test::Request->new;
	if (ref($res[0]) && $res[0]->[2]) {