1use strict; 2use warnings; 3use open ':std', ':encoding(utf8)'; 4 5use Test::More; 6use Prima::sys::Test; 7use Prima::Application; 8use open ':std', ':encoding(utf8)'; 9 10my $x; 11 12sub t 13{ 14 my $f = shift; 15 16 $x->set_font({ 17 name => $f->{name}, 18 height => $f->{height} || 10, 19 pitch => $f->{pitch}, 20 encoding => $f->{encoding}, 21 }); 22 23 my $ok = 1; 24 for ( qw( height size direction)) { 25 my $fx = $x-> font-> $_(); 26 $x-> font( $_ => $x-> font-> $_() * 3 + 12); 27 my $fx2 = $x-> font-> $_(); 28 SKIP: { 29 if ( $fx2 == $fx || $x->font->name ne $f->{name}) { 30 skip "$_", 1; 31 next; 32 } 33 $x-> font( $_ => $fx); 34 $ok &= is( $x-> font-> $_(), $fx, "$_ / $f->{name}"); 35 }; 36 } 37 38 # width is a bit special, needs height or size 39 for (qw( height size)) { 40 my $fh = $x-> font-> $_(); 41 $x-> font( $_ => $fh ); # size can be fractional inside 42 my $fw = $x-> font-> width; 43 my $fn = $x-> font-> name; 44 $x-> font( $_ => $fh, width => $fw * 3 + 12); 45 my $fw2 = $x-> font-> width; 46 SKIP: { 47 if ( $fw2 == $fw || $x->font->name ne $f->{name}) { 48 skip "width / $f->{name}", 1; 49 next; 50 } 51 $x-> font( $_ => $fh, width => $fw, name => $fn ); 52 $ok &= is( $x-> font-> width, $fw, "width by $_ / $f->{name}"); 53 }; 54 } 55 56 57 # style 58 my $fx = $x-> font-> style; 59 my $newfx = ~$fx; 60 $x-> font( style => $newfx); 61 my $fx2 = $x-> font-> style; 62 SKIP : { 63 if ( $fx2 == $fx || $x->font->name ne $f->{name}) { 64 skip "style", 1; 65 } 66 $x-> font( style => $fx); 67 is( $x-> font-> style, $fx, "style / $f->{name}"); 68 }; 69 70 # wrapping 71 SKIP : { 72 $x-> font-> height( 16); 73 my ($a,$b,$c) = @{$x->get_font_abc(ord('e'),ord('e'))}; 74 my $w = $a + $b + $c; 75 skip "text wrap $f->{name}", 1 if $w <= 1; # some non-latin or symbol font 76 cmp_ok( scalar @{$x-> text_wrap( "eeee eeee eeee eeee eeee", $w * 5)}, '>', 4, "text wrap $f->{name}"); 77 } 78 79 return $ok; 80} 81 82my $filter = @ARGV ? qr/$ARGV[0]/ : qr/./; 83my $bad_guys = qr/( 84 Color\sEmoji| # fontconfig doesn't support this .ttc, reports crazy numbers and cannot display it 85 Pebble # no glyphs in the font? 86)/x; 87 88$x = Prima::DeviceBitmap-> create( type => dbt::Bitmap, width => 8, height => 8); 89my @fonts; 90for my $f ( @{$::application->fonts} ) { 91 next if $f->{name} =~ /$bad_guys/; 92 next unless $f->{name} =~ /$filter/; 93 push @fonts, $f; 94} 95 96plan tests => scalar(@fonts) * 7; 97 98for my $f ( @fonts ) { 99 if (!t($f) && Prima::Application-> get_system_info-> {apc} == apc::Unix) { 100 Prima::options(debug => 'f'); 101 t($f); 102 Prima::options(debug => '0'); 103 } 104} 105$x-> destroy; 106 107done_testing; 108