view release on metacpan or  search on metacpan

t/badge-simple.t  view on Meta::CPAN

=begin comment

CPAN Testers has shown that there are slight variations in the
calculation of the font widths. I'm currently assuming this is
because of differences in the underlying font libraries. An
analysis by F<scrape_cpantesters.pl> on 2018-11-04 showed the
differences as recorded in the C<%samples> hash below.

Disclaimer: I don't like this solution, but here it is anyway. If
you can think of a better way to handle this, please let me know.

In C<pick_apart_svg>, I pull all the relevant width attributes
that were generated by C<Badge::Simple::badge()> back out of the
XML. Then, I check that the widths are within some deltas that I
derived from the CPAN Testers reports. At the moment, these deltas
seem fairly large to me, but I'll have to see what CPAN Testers
reports back about this version of the tests and go from there.

=end comment

=cut


sub test_is_svg_similar { # testing our tests...
	my %samples = (
		"hello.svg"  => { exp  => "<svg xmlns=\"http://www.w3.org/2000/svg\" height=\"20\" width=\"83\" ><linearGradient id=\"smooth\" x2=\"0\" y2=\"100%\"><stop offset=\"0\" stop-color=\"#bbb\" stop-opacity=\".1\"></stop><stop offset=\"1\" stop-opacity=\"...
		                  got1 => "<svg xmlns=\"http://www.w3.org/2000/svg\" height=\"20\" width=\"87\" ><linearGradient id=\"smooth\" x2=\"0\" y2=\"100%\"><stop offset=\"0\" stop-color=\"#bbb\" stop-opacity=\".1\"></stop><stop offset=\"1\" stop-opacity=\"...
		                  got2 => "<svg xmlns=\"http://www.w3.org/2000/svg\" height=\"20\" width=\"87\" ><linearGradient id=\"smooth\" x2=\"0\" y2=\"100%\"><stop offset=\"0\" stop-color=\"#bbb\" stop-opacity=\".1\"></stop><stop offset=\"1\" stop-opacity=\"...
		"cpt100.svg" => { exp  => "<svg xmlns=\"http://www.w3.org/2000/svg\" height=\"20\" width=\"129\"><linearGradient id=\"smooth\" x2=\"0\" y2=\"100%\"><stop offset=\"0\" stop-color=\"#bbb\" stop-opacity=\".1\"></stop><stop offset=\"1\" stop-opacity=\"...
		                  got1 => "<svg xmlns=\"http://www.w3.org/2000/svg\" height=\"20\" width=\"131\"><linearGradient id=\"smooth\" x2=\"0\" y2=\"100%\"><stop offset=\"0\" stop-color=\"#bbb\" stop-opacity=\".1\"></stop><stop offset=\"1\" stop-opacity=\"...
		                  got2 => "<svg xmlns=\"http://www.w3.org/2000/svg\" height=\"20\" width=\"132\"><linearGradient id=\"smooth\" x2=\"0\" y2=\"100%\"><stop offset=\"0\" stop-color=\"#bbb\" stop-opacity=\".1\"></stop><stop offset=\"1\" stop-opacity=\"...
		"foo.svg"    => { exp  => "<svg xmlns=\"http://www.w3.org/2000/svg\" height=\"20\" width=\"59\" ><linearGradient id=\"smooth\" x2=\"0\" y2=\"100%\"><stop offset=\"0\" stop-color=\"#bbb\" stop-opacity=\".1\"></stop><stop offset=\"1\" stop-opacity=\"...
		                  got1 => "<svg xmlns=\"http://www.w3.org/2000/svg\" height=\"20\" width=\"60\" ><linearGradient id=\"smooth\" x2=\"0\" y2=\"100%\"><stop offset=\"0\" stop-color=\"#bbb\" stop-opacity=\".1\"></stop><stop offset=\"1\" stop-opacity=\"...
		                  got2 => "<svg xmlns=\"http://www.w3.org/2000/svg\" height=\"20\" width=\"61\" ><linearGradient id=\"smooth\" x2=\"0\" y2=\"100%\"><stop offset=\"0\" stop-color=\"#bbb\" stop-opacity=\".1\"></stop><stop offset=\"1\" stop-opacity=\"...
	);
	for my $k (sort keys %samples) {
		for my $bk ( sort keys %{$samples{$k}} ) {
			is_svg_similar(
				XML::LibXML->load_xml( string => $samples{$k}{$bk} ),
				XML::LibXML->load_xml( string => $samples{$k}{exp} ),
				"is_svg_similar $k $bk" );
		}
	}
	return;
}

sub is_svg_similar ($$;$) {  ## no critic (ProhibitSubroutinePrototypes)
	my ($got_doc,$exp_doc,$name) = @_;
	return subtest $name => sub {
		if ($exp_doc->toStringC14N eq $got_doc->toStringC14N) {
			pass "toStringC14N *exact* match";
			return } # else:
		my $exp = pick_apart_svg($exp_doc);
		my $got = pick_apart_svg($got_doc);
		is $got->{xml}, $exp->{xml}, 'NO exact match; cleaned XML matches';
		for my $k (qw/ total_w l_w r_w l_txt_c r_txt_c /) {
			my $delta = abs( $exp->{$k} - $got->{$k} );
			my $max_err = $k eq 'total_w' ? 8 : 4; #TODO Later: Can we make these smaller?
			if ($exp->{$k}<100) # for lengths of <100 pixels, apply error to pixel count
				{ ok $delta<=$max_err, "$k: exp $$exp{$k}, got $$got{$k}, delta $delta is <= ${max_err}px" }
			else { # for lengths of >=100 pixels, apply error to percentage difference
				my $percent = sprintf "%0.1f", 100*$delta/$exp->{$k};
				ok $percent<=$max_err, "$k: exp $$exp{$k}, got $$got{$k}, delta $delta ($percent%) <= $max_err%";
			}
		}
	};
}

sub pick_apart_svg {
	my $dom = shift;
	my $xpc = XML::LibXML::XPathContext->new($dom);
	$xpc->registerNs('s', 'http://www.w3.org/2000/svg');
	my (%attr,%out);
	
	# $total_w shows up three times:
	$attr{total_w_1} = $xpc->find('/s:svg/@width')->get_node(0);
	$attr{total_w_2} = $xpc->find('/s:svg/s:clipPath/s:rect/@width')->get_node(0);
	die $attr{total_w_2} unless $attr{total_w_2}->value eq $attr{total_w_1}->value;
	$attr{total_w_3} = $xpc->find('/s:svg/s:g[1]/s:rect[3]/@width')->get_node(0);
	die $attr{total_w_3} unless $attr{total_w_3}->value eq $attr{total_w_1}->value;
	$out{total_w} = $attr{total_w_1}->value;
	$attr{"total_w_$_"}->setValue('total_w') for 1..3;
	
	# $l_w shows up twice:
	$attr{l_w_1} = $xpc->find('/s:svg/s:g[1]/s:rect[1]/@width')->get_node(0);
	$attr{l_w_2} = $xpc->find('/s:svg/s:g[1]/s:rect[2]/@x')->get_node(0);
	die $attr{l_w_2} unless $attr{l_w_2}->value eq $attr{l_w_1}->value;
	$out{l_w} = $attr{l_w_1}->value;
	$attr{"l_w_$_"}->setValue('l_w') for 1..2;
	
	# $r_w shows up once:
	$attr{r_w_1} = $xpc->find('/s:svg/s:g[1]/s:rect[2]/@width')->get_node(0);
	$out{r_w} = $attr{r_w_1}->value;
	$attr{"r_w_1"}->setValue('r_w');
	
	# $l_txt_c shows up twice:
	$attr{l_txt_c_1} = $xpc->find('/s:svg/s:g[2]/s:text[1]/@x')->get_node(0);
	$attr{l_txt_c_2} = $xpc->find('/s:svg/s:g[2]/s:text[2]/@x')->get_node(0);
	die $attr{l_txt_c_2} unless $attr{l_txt_c_2}->value eq $attr{l_txt_c_1}->value;
	$out{l_txt_c} = $attr{l_txt_c_1}->value;
	$attr{"l_txt_c_$_"}->setValue('l_txt_c') for 1..2;
	
	# $r_txt_c shows up twice:
	$attr{r_txt_c_1} = $xpc->find('/s:svg/s:g[2]/s:text[3]/@x')->get_node(0);
	$attr{r_txt_c_2} = $xpc->find('/s:svg/s:g[2]/s:text[4]/@x')->get_node(0);
	die $attr{r_txt_c_2} unless $attr{r_txt_c_2}->value eq $attr{r_txt_c_1}->value;
	$out{r_txt_c} = $attr{r_txt_c_1}->value;
	$attr{"r_txt_c_$_"}->setValue('r_txt_c') for 1..2;
	
	$out{xml} = $dom->toStringC14N();
	
	return \%out;
}