view release on metacpan or  search on metacpan

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

sub _decode_utf8_arr {
	my $arr = shift;
	return $arr if ref($arr) ne 'ARRAY'; # DateTime for example
	for (my $i = 0; $i < @$arr; $i++) {
		my $r = ref($arr->[$i]);
		$arr->[$i] = $r ? $r eq 'ARRAY' ? _decode_utf8_arr($arr->[$i])
						: _decode_utf8($arr->[$i])
				: Encode::decode_utf8($arr->[$i]);

	}
	return $arr;
}

sub _decode_utf8 {
	my $arg = shift;
	($arg->{$_} = ref($arg->{$_}) ? _decode_utf8_arr($arg->{$_})
			: Encode::decode_utf8($arg->{$_})) for (keys %$arg);
	return $arg;
}

sub _direct_ht_render {
	my ($self, $handler_class, %args) = @_;
	my $res = $self->_direct_render($handler_class, %args);
	my @cs = HTML::Tested::Test->check_stash($handler_class->ht_root_class
		, $res, _decode_utf8($args{ht}));
	push @cs, $res if @cs;
	return @cs;
}

sub _mech_ht_render {
	my ($self, $handler_class, %args) = @_;
	my $content = $self->_mech_render($handler_class, %args);
	return HTML::Tested::Test->check_text(
			$handler_class->ht_root_class, $content, $args{ht});
}

sub _direct_ht_update {
	my ($self, $handler_class, %args) = @_;
	my $r = $self->_make_test_request(\%args);
	my $rc = $handler_class->ht_root_class;
	HTML::Tested::Test->convert_tree_to_param($rc, $r, $args{ht});
	HTML::Tested::Test->convert_tree_to_param($rc, $r, $args{param})
		if $args{param};
	return $self->_do_swit_update($handler_class, $r, %args);
}

sub _mech_ht_update {
	my ($self, $handler_class, %args) = @_;
	my $r = Apache::SWIT::Test::Request->new({ _param => $args{fields} });
	HTML::Tested::Test->convert_tree_to_param(
			$handler_class->ht_root_class, $r, $args{ht});
	$args{fields} = $r->_param;
	delete $args{ht};
	delete $args{param};

	if (my $form_number = $args{'form_number'}) {
		$self->mech->form_number($form_number) or confess "No number";
	} elsif (my $form_name = $args{'form_name'}) {
		$self->mech->form_name($form_name) or confess "No form_name";
	}
	goto OUT unless $r->upload;

	my $form = $self->mech->current_form or confess "No form found!";
	confess "Form method is not POST" if uc($form->method) ne "POST";
	confess "Form enctype is not multipart/form-data"
	           if $form->enctype ne "multipart/form-data";

	for my $u (map { $r->upload($_) } $r->upload) {
		my $i = $self->mech->current_form->find_input($u->name)
			or die "Unable to find input for " . $u->name;
		if ($i->can('content')) {
			my $c = read_file($u->fh);
			$i->content($c);
			$i->filename($u->filename);
		} else {
			# Mozilla::Mechanize::Input
			$i->{input}->SetValue($u->filename);
		}
	}
OUT:
	return $self->_mech_update($handler_class, %args);
}

sub _make_test_function {
	my ($class, $handler_class, $op, $url) = @_; 
	return sub {
		my ($self, %a) = @_;
		$a{url_to_make} = $url;
		my $f = $self->mech ? "_mech_$op" : "_direct_$op";
		return $self->$f($handler_class, %a);
	};
}

sub make_aliases {
	my ($class, %args) = @_;
	my %trans = (r => 'render', u => 'update');
	while (my ($n, $v) = each %args) {
		no strict 'refs';
		while (my ($f, $t) = each %trans) {
			my $func = "$n\_$f";
			$func =~ s/[\/\.]/_/g;
			my $url = "$n/$f";
			*{ "$class\::$func" } = 
				$class->_make_test_function($v, $t, $url);
			*{ "$class\::ht_$func" } = 
				$class->_make_test_function($v
						, "ht_$t", $url);
		}
		my $r_func = "ht_$n\_r";
		$r_func =~ s/\//_/g;
		*{ "$class\::ok_$r_func" } = sub {
			my $self = shift;
			my @tre = $self->$r_func(@_);
			my $ftr = shift @tre;
			return ok(1) unless defined($ftr);

			Carp::cluck("# Failed");
			carp("# $ftr " . ($self->mech ? "" : " " . Dumper(\@tre)));
			return ok(0);
		};
	}
}

=head2 $test->ok_follow_link(%args)

See WWW::Mechanize for possible C<%args> values.

Returns 1 on success, C<undef> on failure. -1 in direct test.