File Coverage

blib/lib/Text/FIGlet/Font.pm
Criterion Covered Total %
statement 179 186 96.2
branch 82 116 70.6
condition 60 77 77.9
subroutine 12 12 100.0
pod 2 2 100.0
total 335 393 85.2


line stmt bran cond sub pod time code
1             package Text::FIGlet::Font;
2 8     8   52 use strict;
  8         16  
  8         255  
3 7     7   42 use vars qw($REwhite $VERSION);
  7         12  
  7         288  
4 5     5   26 use Carp qw(cluck confess);
  5         8  
  5         229  
5 5     5   1528 use Symbol; #5.005 support
  5         2561  
  5         238  
6 4     4   1564 use Text::Wrap;
  4         9242  
  4         242  
7             $VERSION = '2.19.3';
8              
9             #'import' core support functions from parent with circular dependency
10             foreach( qw/UTF8len UTF8ord _canonical _no _utf8_on/){
11 4     4   25 no strict 'refs';
  4         7  
  4         8842  
12             *$_ = *{'Text::FIGlet::'.$_};
13             }
14              
15              
16             sub new{
17 17     17 1 33 shift();
18 17         92 my $self = {_maxLen=>0, -U=>-1, -m=>-2, @_};
19 17 100 100     135 $self->{-m} = -3 if defined($self->{-m}) && $self->{-m} eq '-0';
20 17   50     88 $self->{-f} ||= $ENV{FIGFONT} || 'standard';
      66        
21 17   50     70 $self->{-d} ||= $ENV{FIGLIB} || '/usr/games/lib/figlet/';
      66        
22 17         50 _load_font($self);
23 17         1288 bless($self);
24             }
25              
26             sub _load_font{
27 17     17   30 my $self = shift();
28 17         52 my $font = $self->{_font} = [];
29 17         32 my(@header, $header, $path, $ext);
30 17         24 local($_);
31              
32             #MAGIC minifig0
33 17         194 $self->{_file} = _canonical($self->{-d}, $self->{-f}, qr/\.[ft]lf/,
34             $^O =~ /MSWin32|DOS/i);
35             #XXX bsd_glob .[ft]lf
36 17 50       1806 $self->{_file} = (glob($self->{_file}.'.?lf'))[0] unless -e $self->{_file};
37              
38             #open(FLF, $self->{_file}) || confess("$!: $self->{_file}");
39 17         121 $self->{_fh} = gensym; #5.005 support
40 4     4   2157 eval "use IO::Uncompress::Unzip"; #XXX sniff for 'PK\003\004'instead?
  4     4   207589  
  4         177  
  4         31  
  4         8  
  4         154  
  17         1555  
41 17 50       75 unless( $@ ){
42 17   33     29 $self->{_fh} = eval{ IO::Uncompress::Unzip->new($self->{_file}) } ||
43             confess("No such file or directory: $self->{_file}");
44             }
45             else{
46 0 0       0 open($self->{_fh}, '<'.$self->{_file}) || confess("$!: $self->{_file}");
47             #$^W isn't mutable at runtime in 5.005, so we have to conditional eval
48             #to avoid "Useless use of constant in void context"
49 0 0       0 eval "binmode(\$fh, ':encoding(utf8)')" unless $] < 5.006;
50             }
51             #MAGIC minifig1
52              
53 17         12525 my $fh = $self->{_fh}; #5.005 support
54 17         85 chomp($header = <$fh>); #5.005 hates readline & $self->{_fh} :-/
55 17 50       3365 confess("Invalid FIGlet 2/TOIlet font") unless $header =~ /^[ft]lf2/;
56              
57             #flf2ahardblank height up_ht maxlen smushmode cmt_count rtol
58 17         155 @header = split(/\s+/, $header);
59 17         77 $header[0] =~ s/^[ft]lf2.//;
60             #$header[0] = qr/@{[sprintf "\\%o", ord($header[0])]}/;
61 17         45 $header[0] = quotemeta($header[0]);
62 17         80 $self->{_header} = \@header;
63              
64 17 100 100     110 if( defined($self->{-m}) && $self->{-m} eq '-2' ){
65 3         31 $self->{-m} = $header[4];
66             }
67              
68             #Discard comments
69 17   33     127 <$fh> for 1 .. $header[5] || cluck("Unexpected end of font file") && last;
70              
71             #Get ASCII characters
72 17         12175 foreach my $i(32..126){
73 1615 50       2630 &_load_char($self, $i) || last;
74             }
75              
76             #German characters?
77 17 50       236 unless( eof($fh) ){
78 17         270 my %D =(91=>196, 92=>214, 93=>220, 123=>228, 124=>246, 125=>252, 126=>223);
79              
80 17         135 foreach my $k ( sort {$a <=> $b} keys %D ){
  213         318  
81 119 50       235 &_load_char($self, $D{$k}) || last;
82             }
83 17 100       106 if( $self->{-D} ){
84 1         12 $font->[$_] = $font->[$D{$_}] for keys %D;
85             #removal is necessary to prevent 2nd reference to same figchar,
86             #which would then become over-smushed; alas 5.005 can't delete arrays
87 1         3 $#{$font} = 126; #undef($font->[$_]) for values %D;
  1         5  
88             }
89             }
90              
91             #ASCII bypass
92 17 100       104 close($fh) unless $self->{-U};
93              
94             #Extended characters, with extra readline to get code
95 17         726 until( eof($fh) ){
96 1636   33     9827 $_ = <$fh> || cluck("Unexpected end of font file") && last;
97            
98 1636         98944 /^\s*$Text::FIGlet::RE{no}/;
99 1636 50       3963 last unless $2;
100 1636         3244 my $val = _no($1, $2, $3, 1);
101            
102             #Bypass negative chars?
103 1636 50 66     4540 if( $val > Text::FIGlet->PRIVb && $self->{-U} == -1 ){
104 0         0 readline($fh) for 0..$self->{_header}->[1]-1;
105             }
106             else{
107             #Clobber German chars
108 1636         10255 $font->[$val] = '';
109 1636 50       2456 &_load_char($self, $val) || last;
110             }
111             }
112 17         925 close($fh);
113              
114              
115             #Fixed width
116 17 100 100     855 if( defined($self->{-m}) && $self->{-m} == -3 ){
    100 100        
    50 66        
117 1         4 my $pad;
118 1         3 for(my $ord=0; $ord < scalar @{$font}; $ord++){
  735         1080  
119 734 100       1071 next unless defined $font->[$ord];
120 324         454 foreach my $i (-$header[1]..-1){
121             #next unless exists($font->[$ord]->[2]); #55compat
122 1944 50       3103 next unless defined($font->[$ord]->[2]);
123              
124             # The if protects from a a 5.6(.0)? bug
125 1944 50       6168 $font->[$ord]->[$i] =~ s/^\s{1,$font->[$ord]->[1]}//
126             if $font->[$ord]->[1];
127              
128 1944         3709 $pad = $self->{_maxLen} - UTF8len($font->[$ord]->[$i]);
129             # print STDERR "$pad = $self->{_maxLen} - UTF8len($font->[$ord]->[$i]);\n";
130 1944         5390 $font->[$ord]->[$i] = " " x int($pad/2) .
131             $font->[$ord]->[$i] . " " x ($pad-int($pad/2));
132             }
133             }
134             }
135             #Full width
136             elsif( defined($self->{-m}) && $self->{-m} == -1 ){
137 11         35 for(my $ord=32; $ord < scalar @{$font}; $ord++){
  23999         32443  
138 23988 100       32930 next unless defined $font->[$ord];
139 1376         1847 foreach my $i (-$header[1]..-1){
140 6528 50       8987 next unless $font->[$ord]->[$i];
141             # The if protects from a a 5.6(.0)? bug
142 6528 100       17667 $font->[$ord]->[$i] =~ s/^\s{1,$font->[$ord]->[1]}//
143             if $font->[$ord]->[1];
144 6528         9902 substr($font->[$ord]->[$i], 0, 0, ' 'x$font->[$ord]->[1]);
145 6528         9565 $font->[$ord]->[$i] .= ' 'x$font->[$ord]->[2];
146             }
147             }
148             }
149             #Kern glyph boxes
150             elsif( !defined($self->{-m}) || $self->{-m} > -1 ){
151 5         16 for(my $ord=32; $ord < scalar @{$font}; $ord++){
  1047310         1381145  
152 1047305 100       1449365 next unless defined $font->[$ord];
153 1621         2113 foreach my $i (-$header[1]..-1){
154 9726 50       14131 next unless $font->[$ord]->[$i];
155             # The if protects from a a 5.6(.0)? bug
156 9726 100       28271 $font->[$ord]->[$i] =~ s/^\s{1,$font->[$ord]->[1]}//
157             if $font->[$ord]->[1];
158             }
159             }
160             }
161             }
162              
163              
164             sub _load_char{
165 3370     3370   4681 my($self, $i) = @_;
166 3370         4342 my $font = $self->{_font};
167 3370         5018 my($length, $wLead, $wTrail, $end, $line, $l) = 0;
168            
169 3370         4959 $wLead = $wTrail = $self->{_header}->[3];
170              
171 3370         3871 my $fh = $self->{_fh}; #5.005 support
172            
173 3370         3527 my $REtrail;
174 3370         8646 foreach my $j (0..$self->{_header}->[1]-1){
175 18492   33     37951 $line = $_ = <$fh> ||
176             cluck("Unexpected end of font file") && return 0;
177             #This is the end.... this is the end my friend
178 18492 100       1065869 unless( $REtrail ){
179 3370         12479 /(.)\s*$/;
180 3370         5200 $end = $1;
181             #The negative leading anchor is for term.flf 0x40
182 3370         18847 $REtrail = qr/(?{_header}->[0]]+)\Q$end{1,2}\E?\s*$/;
183             }
184 18492 100 100     81533 if( $wLead && s/^(\s+)// ){
185 17359 100       36782 $wLead = $l if ($l = length($1)) < $wLead;
186             }
187             else{
188 1133         1420 $wLead = 0;
189             }
190 18492 50 66     38439 if( $wTrail && /$REtrail/ ){
191 0 0       0 $wTrail = $l if ($l = length($1)) < $wTrail;
192             }
193             else{
194 18492         20735 $wTrail = 0;
195             }
196 18492 100 100     32426 $length = $l if ($l = UTF8len($_)
197             -(s/(\Q$end\E+)$/$end/&&UTF8len($1)) ) > $length;
198 18492         42370 $font->[$i] .= $line;
199             }
200             #XXX :-/ stop trying at 125 in case of charmap in ~ or extended....
201 3370 100 100     7817 $self->{_maxLen} = $length if $i < 126 && $self->{_maxLen} < $length;
202              
203             #Ideally this would be /o but then all figchar's must have same EOL
204 3370         40580 $font->[$i] =~ s/\015|\Q$end\E{1,2}\s*\r?$//mg;
205 3370         35244 $font->[$i] = [$length,#maxLen
206             $wLead, #wLead
207             $wTrail,#wTrail
208             split(/\r|\r?\n/, $font->[$i])];
209 3370         13878 return 1;
210             }
211              
212              
213             sub figify{
214 21     21 1 23849 my $self = shift();
215 21         90 my $font = $self->{_font};
216 21         157 my %opts = (-A=>'', -X=>'', -x=>'', -w=>'', -U=>0, @_);
217 21         45 my @buffer;
218 21         58 local $_;
219              
220 21   100     125 $opts{-w} ||= 80;
221              
222             #Prepare the input
223 21 50 66     178 $opts{-X} ||= $self->{_header}->[6] ? 'R' : 'L';
224 21 100       73 if( $opts{-X} eq 'R' ){
225 1         8 $opts{-A} = join('', reverse(split('', $opts{-A})));
226             }
227              
228 21         61 $opts{-A} =~ y/\t/ /;
229 21 50       73 $opts{-A} =~ s%$/%\n% unless $/ eq "\n";
230 21 100 100     135 if( defined($self->{-m}) && $self->{-m} == -3 ){
    50          
231 1         7 $Text::Wrap::columns = int($opts{-w} / $self->{_maxLen})+1;
232 1 50       4 $Text::Wrap::columns =2 if $Text::Wrap::columns < 2;
233 1         6 $opts{-A} = Text::Wrap::wrap('', '', $opts{-A});
234 1 50       251 &Encode::_utf8_off($opts{-A}) if $] >= 5.008;
235             }
236             elsif( $opts{-w} > 0 ){
237 20 50       154 &Encode::_utf8_off($opts{-A}) if $] >= 5.008;
238 20         41 $Text::Wrap::columns = $opts{-w}+1;
239 20 50       60 unless( $opts{-w} == 1 ){
240 20         56 ($_, $opts{-A}) = ($opts{-A}, '');
241             # $opts{-A} .= "\0"x(($font->[ ord($1) ]->[0]||1)-1) . $1 while /(.)/g;
242 20 100       201 while( $opts{-U} ?
243             /$Text::FIGlet::RE{UTFchar}/g :
244             /$Text::FIGlet::RE{bytechar}/g ){
245             $opts{-A} .= "\0"x(($font->[
246 102   100     613 $opts{-U} ? UTF8ord($1) : ord($1)
247             ]->[0]||1)-1) . $1;
248             }
249             }
250             #XXX pre 5.8 Text::Wrap is not Unicode happy?
251 20         104 $opts{-A} = Text::Wrap::wrap('', '', $opts{-A});
252 20         3828 $opts{-A} =~ tr/\0//d;
253             }
254              
255             #Assemble glyphs
256 21 100 100     138 my $X = defined($self->{-m}) && $self->{-m} < 0 ? '' : "\000";
257 21         75 foreach( split("\n", $opts{-A}) ){
258 23         36 my(@lchars, @lines);
259 23         83 s/^\s*//o; #XXX
260             # push(@lchars, ord $1) while /(.)/g;
261 23 100       166 while( $opts{-U} ?
262             /$Text::FIGlet::RE{UTFchar}/g :
263             /$Text::FIGlet::RE{bytechar}/g ){
264 111 100       430 push @lchars, ($opts{-U} ? UTF8ord($1) : ord($1));
265             }
266              
267 23         82 foreach my $i (-$self->{_header}->[1]..-1){
268 129         148 my $line='';
269 129         166 foreach my $lchar (@lchars){
270 585 50       749 if( $font->[$lchar] ){
271 585 50       1040 $line .= $font->[$lchar]->[$i] . $X if $font->[$lchar]->[$i];
272             }
273             else{
274 0         0 $line .= $font->[32]->[$i] . $X;
275             }
276             }
277              
278 129         265 $line =~ s/\000$//;
279 129         214 push @lines, $line;
280             }
281              
282             #Kern glyphs?
283 23 100 100     105 if( !defined($self->{-m}) || $self->{-m} > -1 ){
284 13         35 for(my $nulls = 0; $nulls < scalar @lchars ; $nulls++){
285 47         68 my $matches = 0;
286 47         57 my @temp;
287 47         81 for(my $i=0; $i
288 300         2475 $matches += ($temp[$i] = $lines[$i]) =~
289             s/^([^\000]*(?:\000[^\000]*){$nulls})(?: \000|\000(?: |\Z))/$1\000/;
290            
291             #($_ = $temp[$i]) =~ s/(${stem}{$nulls})/$1@/;
292             #print "$nulls, $i) $matches == @{[scalar @lines]} #$_\n";
293 300 100 100     1290 if( $i == scalar(@lines)-1 && $matches == scalar @lines ){
294 3         11 @lines = @temp;
295 3         5 $matches = 0;
296 3         8 $i = -1;
297             }
298             }
299             }
300             }
301              
302 23         69 push @buffer, @lines;
303             }
304              
305              
306             #Layout
307 21 100 66     156 $opts{-x} ||= $opts{-X} eq 'R' ? 'r' : 'l';
308 21         43 foreach my $line (@buffer){
309             #Smush
310 129 100 100     331 if( !defined($self->{-m}) || $self->{-m} > 0 ){
311            
312              
313             #Universal smush/overlap
314 18         31 $line =~ s/\000 //g;
315 18         107 $line =~ s/$Text::FIGlet::RE{UTFchar}\000//g;
316             }
317             else{
318 111         156 $line =~ y/\000//d;
319             }
320              
321             #Alignment
322 129 100       283 if( $opts{-x} eq 'c' ){
    100          
323 6         18 $line = " "x(($opts{-w}-UTF8len($line))/2) . $line;
324             }
325             elsif( $opts{-x} eq 'r' ){
326 12         23 $line = " "x($opts{-w}-UTF8len($line)) . $line;
327             }
328              
329             #Replace hardblanks
330 129         321 $line =~ s/$self->{_header}->[0]/ /g;
331             }
332              
333              
334 21 50       96 if( $] < 5.006 ){
335 0 0       0 return wantarray ? @buffer : join($/, @buffer).$/;
336             }
337             else{
338             #Properly promote (back) to utf-8
339 21 50       738 return wantarray ? map{_utf8_on($_)} @buffer :
  0            
340             _utf8_on($_=join($/, @buffer).$/);
341             }
342              
343              
344             }
345             1;
346             __END__