view release on metacpan or  search on metacpan

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

use FindBin;
use File::Spec::Functions qw/catfile updir/;
use File::Temp qw/tempfile/;
use XML::LibXML ();
use Imager ();

## no critic (RequireCarping)

use Test::More tests=>7;

BEGIN {
	diag "This is Perl $] at $^X on $^O";
	use_ok 'Badge::Simple', 'badge';
}
is $Badge::Simple::VERSION, '0.04', 'Badge::Simple version matches tests';

my $fontfile = catfile($FindBin::Bin,updir,'lib','Badge','Simple','DejaVuSans.ttf');

{
	diag "Imager::Font version is $Imager::Font::VERSION, available formats are: ",
		join(', ', grep { $Imager::formats{$_} } qw/ tt t1 w32 ft2 /);  ## no critic (ProhibitPackageVars)
	die "Font file $fontfile doesn't exist" unless -e $fontfile;
	diag "Attempting to load font ", explain $fontfile;
	my $font = Imager::Font->new( file => $fontfile )
		or die "failed to load font: ".Imager->errstr;
	diag "Imager::Font class is ", ref $font;
	for my $str ('foo','Yadda yadda','The quick brown fox jumps over the lazy dog.') {
		diag "display_width of '$str' is ",$font->bounding_box(size=>11, string=>$str)->display_width;
	}
}

sub is_svg_similar ($$;$);  ## no critic (ProhibitSubroutinePrototypes)

subtest 'is_svg_similar' => \&test_is_svg_similar;

{
	my $exp = XML::LibXML->load_xml(
		location => catfile($FindBin::Bin, 'hello.svg'),
		no_blanks=>1 );
	my $got = badge( left => "Hello", right => "World!", color => "yellow", font=>$fontfile );
	is_svg_similar $got, $exp, 'hello.svg';
}

{
	my $exp = XML::LibXML->load_xml(
		location => catfile($FindBin::Bin, 'cpt100.svg'),
		no_blanks=>1 );
	my $got = badge( left=>'CPAN Testers', right=>'100%', color=>'brightgreen', font=>$fontfile );
	is_svg_similar $got, $exp, 'cpt100.svg';
}

{
	my $exp = XML::LibXML->load_xml(
		location => catfile($FindBin::Bin, 'foo.svg'),
		no_blanks=>1 );
	my $got = badge( left=>'foo', right=>'bar', color=>'#e542f4', font=>$fontfile );
	is_svg_similar $got, $exp, 'foo.svg';
}

subtest 'CLI' => sub {
	plan $] ge '5.008' ? ( tests=>2 ) : ( skip_all=>'bin/badge requires perl 5.008' );
	
	my ($tfh, $outfile) = tempfile(UNLINK=>1);
	close $tfh;
	
	my $script = catfile($FindBin::Bin, updir, 'bin', 'badge');
	is system($^X, $script, qw/ --left Hello --right World!
		--color yellow --out /, $outfile, '--font', $fontfile ),
		0, 'bin/badge';
	
	my $exp = XML::LibXML->load_xml(
		location => catfile($FindBin::Bin, 'hello.svg'),
		no_blanks=>1 );
	my $got = XML::LibXML->load_xml(
		location => $outfile, no_blanks=>1 );
	is_svg_similar $got, $exp, 'hello.svg';
};

=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" );
		}
	}