File Coverage

blib/lib/Text/Amuse/Compile/Fonts/Import.pm
Criterion Covered Total %
statement 24 127 18.9
branch 0 50 0.0
condition 0 33 0.0
subroutine 8 17 47.0
pod 9 9 100.0
total 41 236 17.3


line stmt bran cond sub pod time code
1             package Text::Amuse::Compile::Fonts::Import;
2 1     1   1112 use utf8;
  1         21  
  1         6  
3 1     1   31 use strict;
  1         2  
  1         18  
4 1     1   4 use warnings;
  1         2  
  1         26  
5 1     1   974 use IPC::Run qw/run/;
  1         44266  
  1         50  
6 1     1   420 use JSON::MaybeXS ();
  1         7711  
  1         25  
7 1     1   457 use Text::Amuse::Compile::Fonts;
  1         3  
  1         36  
8 1     1   8 use Moo;
  1         13  
  1         6  
9 1     1   930 use Data::Dumper;
  1         6257  
  1         1655  
10              
11              
12             =head1 NAME
13              
14             Text::Amuse::Compile::Fonts::Import - create a list of fonts to be used with Text::Amuse::Compile
15              
16             =head1 DESCRIPTION
17              
18             This module is basically an hack. It parses the output of fc-list or
19             identify (from imagemagick) to get a list of font paths.
20              
21             It should work on Windows if imagemagick is installed.
22              
23             =head1 ACCESSOR
24              
25             =head2 output
26              
27             The output file to write the json to. If not provided, it will print on the STDOUT.
28              
29             =head1 PUBLIC METHODS
30              
31             =head2 import_and_save
32              
33             Parse the font list and output it to the file, if provided to the
34             constructor, otherwise print the JSON on the standard output.
35              
36             =head1 INTERNAL METHODS
37              
38             =over 4
39              
40             =item use_fclist
41              
42             =item use_imagemagick
43              
44             =item try_list
45              
46             =item all_fonts
47              
48             =item import_with_fclist
49              
50             =item import_with_imagemagick
51              
52             =item import_list
53              
54             =item as_json
55              
56             =item full_font_list
57              
58             Holds a reference to L
59              
60             =back
61              
62              
63             =cut
64              
65              
66             has output => (is => 'ro');
67              
68             has full_font_list => (is => 'ro', default => sub { Text::Amuse::Compile::Fonts->new });
69              
70             sub use_fclist {
71 0     0 1   return system('fc-list', '--version') == 0;
72             }
73              
74             sub use_imagemagick {
75 0     0 1   return system('identify', '-version') == 0;
76             }
77              
78             sub try_list {
79 0     0 1   my $self = shift;
80             # pick the default list from the Fonts class and add Noto
81 0           my $fonts = $self->full_font_list;
82             my %all = (
83 0           serif => [ map { $_->name } $fonts->serif_fonts ],
84 0           mono => [ map { $_->name } $fonts->mono_fonts ],
85 0           sans => [ map { $_->name } $fonts->sans_fonts ],
  0            
86             );
87 0           return \%all;
88             }
89              
90             sub all_fonts {
91 0     0 1   my $self = shift;
92 0           my $list = $self->try_list;
93 0           my %all;
94 0           foreach my $k (keys %$list) {
95 0           foreach my $font (@{$list->{$k}}) {
  0            
96 0           $all{$font} = $k;
97             }
98             }
99 0           return %all;
100             }
101              
102             sub import_with_fclist {
103 0     0 1   my $self = shift;
104 0 0         return unless $self->use_fclist;
105 0           my %specs;
106 0           my %all = $self->all_fonts;
107 0           my ($in, $out, $err);
108 0           my $ok = run ['fc-list'], \$in, \$out, \$err;
109             # warn $err if $err;
110 0           my @dupes;
111 0           foreach my $line (split(/\r?\n/, $out)) {
112 0 0         if ($line =~ m/(.+?)\s*:
113             \s*(.+?)(\,.+)?\s*:
114             \s*style=(
115             Book|Roman|Medium|Regular|
116             Italic|Oblique|Slanted|
117             Bold|
118             Bold\s*Italic|Bold\s*Oblique|Bold\s*Slanted)(,.*?)?$/x) {
119 0           my $file = $1;
120 0           my $name = $2;
121 0           my $style = lc($4);
122 0 0         next unless $file =~ m/\.(t|o)tf$/i;
123 0           $style =~ s/\s//g;
124 0 0         next unless $all{$name};
125 0 0         if ($specs{$name}{files}{$style}) {
126 0           warn "Duplicated font! $file $name $style $specs{$name}{files}{$style}\n";
127 0           push @dupes, $name;
128             }
129             else {
130 0           $specs{$name}{files}{$style} = $file;
131             }
132             }
133             }
134 0 0         if (@dupes) {
135 0           warn "Deleting duplicated fonts, likely to cause problems:" . join(" ", @dupes). "!\n";
136 0           foreach my $dupe (@dupes) {
137 0           delete $specs{$dupe};
138             }
139             }
140 0           return \%specs;
141            
142             }
143              
144             sub import_with_imagemagick {
145 0     0 1   my $self = shift;
146 0 0         return unless $self->use_imagemagick;
147 0           my %specs;
148 0           my %all = $self->all_fonts;
149 0           my %current;
150 0           my ($in, $out, $err);
151 0           my $ok = run [qw/identify -list font/], \$in, \$out, \$err;
152             # warn $err if $err;
153 0           foreach my $line (split(/\r?\n/, $out)) {
154 0 0         if ($line =~ m/^\s*Font:/) {
    0          
155 0 0 0       if ($current{family} && $current{glyphs} && $current{style} && $current{weight}) {
      0        
      0        
156 0           my $name = $current{family};
157 0           my $file = $current{glyphs};
158 0           my $style;
159 0 0         if ($current{style} eq 'Normal') {
    0          
160 0 0 0       if ($current{weight} == 700) {
    0          
161 0           $style = 'bold';
162             }
163             elsif ($current{weight} == 400 or
164             $current{weight} == 500) {
165 0           $style = 'regular';
166             }
167             }
168             elsif ($current{style} eq 'Italic') {
169 0 0 0       if ($current{weight} == 700) {
    0          
170 0           $style = 'bolditalic';
171             }
172             elsif ($current{weight} == 400 or
173             $current{weight} == 500) {
174 0           $style = 'italic';
175             }
176             }
177 0 0 0       if ($style and $all{$name}) {
178 0 0         if ($specs{$name}{files}{$style}) {
179             # warn "Duplicated font! $file $name $style $specs{$name}{files}{$style}\n";
180             }
181             else {
182 0           $specs{$name}{files}{$style} = $file;
183             }
184             }
185             }
186 0           %current = ();
187             }
188             elsif ($line =~ m/^\s*(\w+):\s+(.+)\s*$/) {
189 0           my ($name, $value) = ($1, $2);
190 0           $current{$name} = $value;
191 0 0 0       if ($name eq 'glyphs' and $value !~ m/\.(t|o)tf\z/i) {
192 0           delete $current{$name};
193             }
194             }
195             }
196 0           return \%specs;
197             }
198              
199             sub import_list {
200 0     0 1   my $self = shift;
201 0           my $list = $self->try_list;
202 0           local $ENV{LC_ALL} = 'C';
203 0   0       my $specs = $self->import_with_fclist || $self->import_with_imagemagick;
204 0 0         die "Cannot retrieve specs, nor with fc-list, nor with imagemagick" unless $specs;
205 0           my %all_default = map { $_->{name} => $_ } @{ $self->full_font_list->default_font_list };
  0            
  0            
206 0           my @out;
207 0           foreach my $type (qw/serif sans mono/) {
208 0           foreach my $font (@{$list->{$type}}) {
  0            
209 0 0         if (my $found = $specs->{$font}) {
210 0           my $files = $found->{files};
211             my %styles = (
212             bold => $files->{bold},
213             bolditalic => $files->{bolditalic} || $files->{boldoblique} || $files->{boldslanted},
214             italic => $files->{italic} || $files->{oblique} || $files->{slanted},
215             regular => $files->{regular} || $files->{book} || $files->{roman} || $files->{medium},
216 0   0       name => $font,
      0        
      0        
217             desc => $font,
218             type => $type,
219             );
220 0 0         if (grep { !$_ } values %styles) {
  0            
221 0           warn "$font is missing styles: " . Dumper(\%styles) . " disabling embedding\n";
222 0           %styles = (
223             name => $font,
224             desc => $font,
225             type => $type,
226             );
227             }
228 0 0         if (my $langs = $all_default{$font}{languages}) {
229 0           $styles{languages} = $langs;
230             }
231 0           push @out, \%styles;
232             }
233             }
234             }
235 0           return \@out;
236             };
237              
238             sub as_json {
239 0     0 1   my $self = shift;
240 0           my $list = $self->import_list;
241 0           return JSON::MaybeXS->new(pretty => 1,
242             canonical => 1,
243             )->encode($list);
244             }
245              
246             sub import_and_save {
247 0     0 1   my $self = shift;
248 0           my $json = $self->as_json;
249 0 0         if (my $file = $self->output) {
250 0 0         open (my $fh, '>', $file) or die $!;
251 0           print $fh $json;
252 0           close $fh;
253             }
254             else {
255 0           print $json;
256             }
257             }
258              
259             1;