File Coverage

blib/lib/HTML/Tested/Test/Value.pm

Criterion	Covered	Total	%
statement	55	64	85.9
branch	21	26	80.7
condition	13	14	92.8
subroutine	15	15	100.0
pod	2	7	28.5
total	106	126	84.1

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

package HTML::Tested::Test::Value;
use HTML::Tested::Test qw(Ensure_Value_To_Check Stash_Mismatch);

sub _replace_sealed {
	my ($class, $val) = @_;
	my $s = HTML::Tested::Seal->instance;
	$val =~ s#([0-9a-f]{16}[0-9a-f]*)#$s->decrypt($1) // 'ENCRYPTED'#eg;
	return $val;
}

=head2 $class->is_marked_as_sealed($e_root, $name)

Checks whether variable C<$name> was marked as HT_SEALED.

=cut
sub is_marked_as_sealed {
	my ($class, $e_root, $name) = @_;
	return $e_root->{"__HT_SEALED__$name"};
}

=head2 $class->handle_sealed($e_root, $name, $e_val, $r_val, $err)

Is called to handle sealed value if needed.

=cut
sub handle_sealed {
	my ($class, $e_root, $name, $e_val, $r_val, $err) = @_;
	if ($class->is_marked_as_sealed($e_root, $name)) {
		my $orig_r_val = $r_val;
		$e_val = $class->_replace_sealed($e_val);
		$r_val = $class->_replace_sealed($r_val);
		push @$err, "$name wasn't sealed $r_val"
			if (($orig_r_val eq $r_val)
					&& !$e_root->{"__HT_REVERTED__$name"});
	} elsif ($e_root->ht_get_widget_option($name, "is_sealed")) {
		push @$err, "HT_SEALED was not defined on $name";
	}
	return ($e_val, $r_val);
}

sub _is_equal {
	my ($class, $e_val, $cb) = @_;
	return 1 if $cb->($e_val);
	return undef unless ($e_val =~ /(\$VAR1 = \[.*\];)/ms);

	my $arr_str = $1;
	my $VAR1;
	eval $arr_str;
	die $@ if $@;
	for (@$VAR1) {
		my $ev = $e_val;
		$ev =~ s#\$VAR1 = \[.*\];\n#$_#ms;
		return 1 if $cb->($ev);
	}
	return undef;
}

sub check_stash {
	my ($class, $e_root, $name, $e_stash, $r_stash) = @_;
	my @err;
	goto OUT unless exists($e_stash->{$name});

	my $e_val = $e_stash->{$name};
	my $r_val = Ensure_Value_To_Check($r_stash, $name, $e_val, \@err);
	goto OUT unless defined($r_val);

	($e_val, $r_val) = $class->handle_sealed($e_root, $name
					, $e_val, $r_val, \@err);
	goto OUT if (@err || $class->_is_equal($e_val
				, sub { $r_val eq $_[0]; }));
	@err = Stash_Mismatch($name, $r_val, $e_val);
OUT:
	return @err;
}

sub bless_from_tree {
	my $class = shift;
	return shift()->bless_from_tree(@_);
}

sub _check_text_i {
	my ($class, $e_root, $name, $v, $text) = @_;
	return () unless defined($v);
	my @ret;
	($v, $text) = $class->handle_sealed($e_root, $name, $v, $text, \@ret);

	my $ok = $class->_is_equal($v, sub { index($text, $_[0]) != -1; });
	return ("Unexpectedly found \"$v\" in \"$text\"")
		if ($ok && $e_root->{"__HT_REVERTED__$name"});
	return ("Unable to find \"$v\" in \"$text\"")
		if (!$ok && !$e_root->{"__HT_REVERTED__$name"});
	return ();
}

sub check_text {
	my ($class, $e_root, $name, $e_stash, $text) = @_;
	return $class->_check_text_i($e_root, $name,
			, $e_stash->{$name}, $text);
}

sub convert_to_param {
	my ($class, $obj_class, $r, $name, $val) = @_;
	$r->param($name, $val);
}

sub convert_to_sealed {
	my ($class, $val) = @_;
	return HTML::Tested::Seal->instance->encrypt($val);
}

1;