1package Text::FIGlet::Font; 2use strict; 3use vars qw($REwhite $VERSION); 4use Carp qw(cluck confess); 5use Symbol; #5.005 support 6use Text::Wrap; 7$VERSION = '2.19.3'; 8 9#'import' core support functions from parent with circular dependency 10foreach( qw/UTF8len UTF8ord _canonical _no _utf8_on/){ 11 no strict 'refs'; 12 *$_ = *{'Text::FIGlet::'.$_}; 13} 14 15 16sub new{ 17 shift(); 18 my $self = {_maxLen=>0, -U=>-1, -m=>-2, @_}; 19 $self->{-m} = -3 if defined($self->{-m}) && $self->{-m} eq '-0'; 20 $self->{-f} ||= $ENV{FIGFONT} || 'standard'; 21 $self->{-d} ||= $ENV{FIGLIB} || '/usr/local/share/figlet/'; 22 _load_font($self); 23 bless($self); 24} 25 26sub _load_font{ 27 my $self = shift(); 28 my $font = $self->{_font} = []; 29 my(@header, $header, $path, $ext); 30 local($_); 31 32#MAGIC minifig0 33 $self->{_file} = _canonical($self->{-d}, $self->{-f}, qr/\.[ft]lf/, 34 $^O =~ /MSWin32|DOS/i); 35 #XXX bsd_glob .[ft]lf 36 $self->{_file} = (glob($self->{_file}.'.?lf'))[0] unless -e $self->{_file}; 37 38 #open(FLF, $self->{_file}) || confess("$!: $self->{_file}"); 39 $self->{_fh} = gensym; #5.005 support 40 eval "use IO::Uncompress::Unzip"; #XXX sniff for 'PK\003\004'instead? 41 unless( $@ ){ 42 $self->{_fh} = eval{ IO::Uncompress::Unzip->new($self->{_file}) } || 43 confess("No such file or directory: $self->{_file}"); 44 } 45 else{ 46 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 eval "binmode(\$fh, ':encoding(utf8)')" unless $] < 5.006; 50 } 51#MAGIC minifig1 52 53 my $fh = $self->{_fh}; #5.005 support 54 chomp($header = <$fh>); #5.005 hates readline & $self->{_fh} :-/ 55 confess("Invalid FIGlet 2/TOIlet font") unless $header =~ /^[ft]lf2/; 56 57 #flf2ahardblank height up_ht maxlen smushmode cmt_count rtol 58 @header = split(/\s+/, $header); 59 $header[0] =~ s/^[ft]lf2.//; 60 #$header[0] = qr/@{[sprintf "\\%o", ord($header[0])]}/; 61 $header[0] = quotemeta($header[0]); 62 $self->{_header} = \@header; 63 64 if( defined($self->{-m}) && $self->{-m} eq '-2' ){ 65 $self->{-m} = $header[4]; 66 } 67 68 #Discard comments 69 <$fh> for 1 .. $header[5] || cluck("Unexpected end of font file") && last; 70 71 #Get ASCII characters 72 foreach my $i(32..126){ 73 &_load_char($self, $i) || last; 74 } 75 76 #German characters? 77 unless( eof($fh) ){ 78 my %D =(91=>196, 92=>214, 93=>220, 123=>228, 124=>246, 125=>252, 126=>223); 79 80 foreach my $k ( sort {$a <=> $b} keys %D ){ 81 &_load_char($self, $D{$k}) || last; 82 } 83 if( $self->{-D} ){ 84 $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 $#{$font} = 126; #undef($font->[$_]) for values %D; 88 } 89 } 90 91 #ASCII bypass 92 close($fh) unless $self->{-U}; 93 94 #Extended characters, with extra readline to get code 95 until( eof($fh) ){ 96 $_ = <$fh> || cluck("Unexpected end of font file") && last; 97 98 /^\s*$Text::FIGlet::RE{no}/; 99 last unless $2; 100 my $val = _no($1, $2, $3, 1); 101 102 #Bypass negative chars? 103 if( $val > Text::FIGlet->PRIVb && $self->{-U} == -1 ){ 104 readline($fh) for 0..$self->{_header}->[1]-1; 105 } 106 else{ 107 #Clobber German chars 108 $font->[$val] = ''; 109 &_load_char($self, $val) || last; 110 } 111 } 112 close($fh); 113 114 115 #Fixed width 116 if( defined($self->{-m}) && $self->{-m} == -3 ){ 117 my $pad; 118 for(my $ord=0; $ord < scalar @{$font}; $ord++){ 119 next unless defined $font->[$ord]; 120 foreach my $i (-$header[1]..-1){ 121 #next unless exists($font->[$ord]->[2]); #55compat 122 next unless defined($font->[$ord]->[2]); 123 124 # The if protects from a a 5.6(.0)? bug 125 $font->[$ord]->[$i] =~ s/^\s{1,$font->[$ord]->[1]}// 126 if $font->[$ord]->[1]; 127 128 $pad = $self->{_maxLen} - UTF8len($font->[$ord]->[$i]); 129# print STDERR "$pad = $self->{_maxLen} - UTF8len($font->[$ord]->[$i]);\n"; 130 $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 for(my $ord=32; $ord < scalar @{$font}; $ord++){ 138 next unless defined $font->[$ord]; 139 foreach my $i (-$header[1]..-1){ 140 next unless $font->[$ord]->[$i]; 141 # The if protects from a a 5.6(.0)? bug 142 $font->[$ord]->[$i] =~ s/^\s{1,$font->[$ord]->[1]}// 143 if $font->[$ord]->[1]; 144 substr($font->[$ord]->[$i], 0, 0, ' 'x$font->[$ord]->[1]); 145 $font->[$ord]->[$i] .= ' 'x$font->[$ord]->[2]; 146 } 147 } 148 } 149 #Kern glyph boxes 150 elsif( !defined($self->{-m}) || $self->{-m} > -1 ){ 151 for(my $ord=32; $ord < scalar @{$font}; $ord++){ 152 next unless defined $font->[$ord]; 153 foreach my $i (-$header[1]..-1){ 154 next unless $font->[$ord]->[$i]; 155 # The if protects from a a 5.6(.0)? bug 156 $font->[$ord]->[$i] =~ s/^\s{1,$font->[$ord]->[1]}// 157 if $font->[$ord]->[1]; 158 } 159 } 160 } 161} 162 163 164sub _load_char{ 165 my($self, $i) = @_; 166 my $font = $self->{_font}; 167 my($length, $wLead, $wTrail, $end, $line, $l) = 0; 168 169 $wLead = $wTrail = $self->{_header}->[3]; 170 171 my $fh = $self->{_fh}; #5.005 support 172 173 my $REtrail; 174 foreach my $j (0..$self->{_header}->[1]-1){ 175 $line = $_ = <$fh> || 176 cluck("Unexpected end of font file") && return 0; 177 #This is the end.... this is the end my friend 178 unless( $REtrail ){ 179 /(.)\s*$/; 180 $end = $1; 181 #The negative leading anchor is for term.flf 0x40 182 $REtrail = qr/(?<!^)([ $self->{_header}->[0]]+)\Q$end{1,2}\E?\s*$/; 183 } 184 if( $wLead && s/^(\s+)// ){ 185 $wLead = $l if ($l = length($1)) < $wLead; 186 } 187 else{ 188 $wLead = 0; 189 } 190 if( $wTrail && /$REtrail/ ){ 191 $wTrail = $l if ($l = length($1)) < $wTrail; 192 } 193 else{ 194 $wTrail = 0; 195 } 196 $length = $l if ($l = UTF8len($_) 197 -(s/(\Q$end\E+)$/$end/&&UTF8len($1)) ) > $length; 198 $font->[$i] .= $line; 199 } 200 #XXX :-/ stop trying at 125 in case of charmap in ~ or extended.... 201 $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 $font->[$i] =~ s/\015|\Q$end\E{1,2}\s*\r?$//mg; 205 $font->[$i] = [$length,#maxLen 206 $wLead, #wLead 207 $wTrail,#wTrail 208 split(/\r|\r?\n/, $font->[$i])]; 209 return 1; 210} 211 212 213sub figify{ 214 my $self = shift(); 215 my $font = $self->{_font}; 216 my %opts = (-A=>'', -X=>'', -x=>'', -w=>'', -U=>0, @_); 217 my @buffer; 218 local $_; 219 220 $opts{-w} ||= 80; 221 222 #Prepare the input 223 $opts{-X} ||= $self->{_header}->[6] ? 'R' : 'L'; 224 if( $opts{-X} eq 'R' ){ 225 $opts{-A} = join('', reverse(split('', $opts{-A}))); 226 } 227 228 $opts{-A} =~ y/\t/ /; 229 $opts{-A} =~ s%$/%\n% unless $/ eq "\n"; 230 if( defined($self->{-m}) && $self->{-m} == -3 ){ 231 $Text::Wrap::columns = int($opts{-w} / $self->{_maxLen})+1; 232 $Text::Wrap::columns =2 if $Text::Wrap::columns < 2; 233 $opts{-A} = Text::Wrap::wrap('', '', $opts{-A}); 234 &Encode::_utf8_off($opts{-A}) if $] >= 5.008; 235 } 236 elsif( $opts{-w} > 0 ){ 237 &Encode::_utf8_off($opts{-A}) if $] >= 5.008; 238 $Text::Wrap::columns = $opts{-w}+1; 239 unless( $opts{-w} == 1 ){ 240 ($_, $opts{-A}) = ($opts{-A}, ''); 241# $opts{-A} .= "\0"x(($font->[ ord($1) ]->[0]||1)-1) . $1 while /(.)/g; 242 while( $opts{-U} ? 243 /$Text::FIGlet::RE{UTFchar}/g : 244 /$Text::FIGlet::RE{bytechar}/g ){ 245 $opts{-A} .= "\0"x(($font->[ 246 $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 $opts{-A} = Text::Wrap::wrap('', '', $opts{-A}); 252 $opts{-A} =~ tr/\0//d; 253 } 254 255 #Assemble glyphs 256 my $X = defined($self->{-m}) && $self->{-m} < 0 ? '' : "\000"; 257 foreach( split("\n", $opts{-A}) ){ 258 my(@lchars, @lines); 259 s/^\s*//o; #XXX 260# push(@lchars, ord $1) while /(.)/g; 261 while( $opts{-U} ? 262 /$Text::FIGlet::RE{UTFchar}/g : 263 /$Text::FIGlet::RE{bytechar}/g ){ 264 push @lchars, ($opts{-U} ? UTF8ord($1) : ord($1)); 265 } 266 267 foreach my $i (-$self->{_header}->[1]..-1){ 268 my $line=''; 269 foreach my $lchar (@lchars){ 270 if( $font->[$lchar] ){ 271 $line .= $font->[$lchar]->[$i] . $X if $font->[$lchar]->[$i]; 272 } 273 else{ 274 $line .= $font->[32]->[$i] . $X; 275 } 276 } 277 278 $line =~ s/\000$//; 279 push @lines, $line; 280 } 281 282 #Kern glyphs? 283 if( !defined($self->{-m}) || $self->{-m} > -1 ){ 284 for(my $nulls = 0; $nulls < scalar @lchars ; $nulls++){ 285 my $matches = 0; 286 my @temp; 287 for(my $i=0; $i<scalar @lines; $i++){ 288 $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 if( $i == scalar(@lines)-1 && $matches == scalar @lines ){ 294 @lines = @temp; 295 $matches = 0; 296 $i = -1; 297 } 298 } 299 } 300 } 301 302 push @buffer, @lines; 303 } 304 305 306 #Layout 307 $opts{-x} ||= $opts{-X} eq 'R' ? 'r' : 'l'; 308 foreach my $line (@buffer){ 309 #Smush 310 if( !defined($self->{-m}) || $self->{-m} > 0 ){ 311 312 313 #Universal smush/overlap 314 $line =~ s/\000 //g; 315 $line =~ s/$Text::FIGlet::RE{UTFchar}\000//g; 316 } 317 else{ 318 $line =~ y/\000//d; 319 } 320 321 #Alignment 322 if( $opts{-x} eq 'c' ){ 323 $line = " "x(($opts{-w}-UTF8len($line))/2) . $line; 324 } 325 elsif( $opts{-x} eq 'r' ){ 326 $line = " "x($opts{-w}-UTF8len($line)) . $line; 327 } 328 329 #Replace hardblanks 330 $line =~ s/$self->{_header}->[0]/ /g; 331 } 332 333 334 if( $] < 5.006 ){ 335 return wantarray ? @buffer : join($/, @buffer).$/; 336 } 337 else{ 338 #Properly promote (back) to utf-8 339 return wantarray ? map{_utf8_on($_)} @buffer : 340 _utf8_on($_=join($/, @buffer).$/); 341 } 342 343 344} 3451; 346__END__ 347=pod 348 349=head1 NAME 350 351Text::FIGlet::Font - font engine for Text::FIGlet 352 353=head1 SYNOPSIS 354 355 use Text::FIGlet; 356 357 my $font = Text::FIGlet->new(-f=>"doh"); 358 359 print ~~$font->figify(-A=>"Hello World"); 360 361=head1 DESCRIPTION 362 363B<Text::FIGlet::Font> reproduces its input as large glyphs made up of other 364characters; usually ASCII, but not necessarily. The output is similar 365to that of many banner programs--although it is not oriented sideways--and 366reminiscent of the sort of I<signatures> many people like to put at the end 367of e-mail and UseNet messages. 368 369B<Text::FIGlet::Font> can print in a variety of fonts, both left-to-right and 370right-to-left, with adjacent glyphs kerned and smushed together in various 371ways. FIGlet fonts are stored in separate files, which can be identified by 372the suffix I<.flf>. Most FIGlet font files will be stored in FIGlet's default 373font directory F</usr/local/share/figlet>. Support for TOIlet fonts I<.tlf>, 374which are typically in the same location, has also been added. 375 376This implementation is known to work with perl 5.005, 5.6 and 5.8, including 377support for Unicode (UTF-8) in all three. See L</CAVEATS> for details. 378 379=head1 OPTIONS 380 381=head2 C<new> 382 383=over 384 385=item B<-d=E<gt>>F<fontdir> 386 387Whence to load files. 388 389Defaults to F</usr/local/share/figlet> 390 391=item B<-D=E<gt>>I<boolean> 392 393B<-D> switches to the German (ISO 646-DE) character set. 394Turns I<[>, I<\> and I<]> into umlauted A, O and U, respectively. 395I<{>, I<|> and I<}> turn into the respective lower case versions of these. 396I<~> turns into s-z. 397 398This option is deprecated, which means it may soon be removed from 399B<Text::FIGlet::Font>. The modern way to achieve this effect is with 400L<Text::FIGlet::Control>. 401 402=item B<-U=E<gt>>I<boolean> 403 404A true value, the default, is necessary to load Unicode font data; 405regardless of your version of perl 406 407B<Note that you must explicitly specify I<1> if you are mapping in negative 408characters with a control file>. See L</CAVEATS> for more details. 409 410=item B<-f=E<gt>>F<fontfile> 411 412The font to load; defaults to F<standard>. 413 414The fontfile may be zipped if L<IO::Uncompress::Unzip> is available. 415A compressed font should contain only the font itself, and the archive 416should be renamed with the B<flf> extension. 417 418=item B<-m=E<gt>>I<layoutmode> 419 420Specifies how B<Text::FIGlet::Font> should "smush" and kern consecutive 421glyphs together. This parameter is optional, and if not specified the 422layoutmode defined by the font author is used. Acceptable values are 423-3 through 63, where positive values are created by adding together the 424corresponding numbers for each desired smush type. 425 426 427 SUMMARY 428 429 Value Width Old CLI Description 430 -3 +++ monospace 431 -1 ++ -W full width 432 0 + -k kern 433 undef - -o overlap/universal smush 434 435 1 - -S -m1 smush equal characters 436 2 - -S -m2 smush underscores 437 4 - -S -m4 smush hierarchy 438 8 - -S -m8 smush opposite pairs 439 16 - -S -m16 smush big X 440 32 - -S -m32 smush hardblanks 441 442 Old CLI is the figlet(6) equivalent option. 443 Monospace is also available via the previous value of -0. 444 445=over 446 447=item I<-3>, Monospace 448 449This will pad each glyph in the font such that they are all the same width. 450The padding is done such that the glyph is centered in it's "box," 451and any odd padding is on the trailing edge. 452 ____ 453 / ___| ___ __ __ 454 | | / _ \ \ \ /\ / / 455 | |___ | (_) | \ V V / 456 \____| \___/ \_/\_/ 457 458 |-----------+-----------+-----------| -- equal-sized boxes 459 460=item I<-1>, Full width 461 462No smushing or kerning, glyphs are simply concatenated together. 463 ____ 464 / ___| ___ __ __ 465 | | / _ \ \ \ /\ / / 466 | |___ | (_) | \ V V / 467 \____| \___/ \_/\_/ 468 469=item I<0>, Kern 470 471Kern only i.e; glyphs are pushed together until they touch. 472 ____ 473 / ___| ___ __ __ 474 | | / _ \\ \ /\ / / 475 | |___| (_) |\ V V / 476 \____|\___/ \_/\_/ 477 478=item I<undef>, Universal smush 479 480Glyphs are kerned, then shifted so that they overlap by column of characters: 481 ____ 482 / ___|_____ __ 483 | | / _ \ \ /\ / / 484 | |__| (_) \ V V / 485 \____\___/ \_/\_/ 486 487=back 488 489Other smush modes are not yet implemented, and therefore fall back to universal. 490 491=back 492 493=head2 C<figify> 494 495Returns a a string or list of lines, depending on context. 496 497=over 498 499=item B<-A=E<gt>>I<text> 500 501The text to transmogrify. 502 503=item B<-U=E<gt>>I<boolean> 504 505Process input as Unicode (UTF-8). 506 507B<Note that this applies regardless of your version of perl>, 508and is necessary if you are mapping in negative characters with a control file. 509 510=item B<-X=E<gt>>I<[LR]> 511 512These options control whether FIGlet prints left-to-right or right-to-left. 513I<L> selects left-to-right printing. I<R> selects right-to-left printing. 514The default is to use whatever is specified in the font file. 515 516=item B<-x=E<gt>>I<[lrc]> 517 518These options handle the justification of B<Text::FIGlet::Font> output. 519I<c> centers the output horizontally. I<l> makes the output flush-left. 520I<r> makes it flush-right. The default sets the justification according 521to whether left-to-right or right-to-left text is selected. Left-to-right 522text will be flush-left, while right-to-left text will be flush-right. 523(Left-to-rigt versus right-to-left text is controlled by B<-X>.) 524 525=item B<-m=E<gt>>I<layoutmode> 526 527Although -B<-m> is best thought of as a font instantiation option, 528it is possible to switch between layout modes greater than zero at 529figification time. Your mileage may vary. 530 531=item B<-w=E<gt>>I<outputwidth> 532 533The output width, output text is wrapped to this value by breaking the 534input on whitspace where possible. There are two special width values 535 536 -1 the text is not wrapped. 537 1 the text is wrapped after every character; most useful with -m=>-3 538 539Defaults to 80 540 541=back 542 543=head1 ENVIRONMENT 544 545B<Text::FIGlet::Font> will make use of these environment variables if present 546 547=over 548 549=item FIGFONT 550 551The default font to load. If undefined the default is F<standard.flf>. 552It should reside in the directory specified by FIGLIB. 553 554=item FIGLIB 555 556The default location of fonts. 557If undefined the default is F</usr/local/share/figlet> 558 559=back 560 561=head1 FILES 562 563FIGlet font files are available at 564 565 ftp://ftp.figlet.org/pub/figlet/ 566 567=head1 SEE ALSO 568 569L<Text::FIGlet>, L<figlet(6)> 570 571=head1 CAVEATS & RESTRICTIONS 572 573=over 574 575=item $/ is used to create the output string in scalar context 576 577Consequently, make sure it is set appropriately i.e.; 578Don't mess with it, B<perl> sets it correctly for you. 579 580=item B<-m=>E<gt>'-0' 581 582This mode is peculiar to B<Text::FIGlet>, and as such, results will vary 583amongst fonts. 584 585=item Support for pre-5.6 perl 586 587This codebase was originally developed to be compatible with 5.005.03, 588and has recently been manually checked against 5.005.05. Unfortunately, 589the default test suite makes use of code that is not compatable with 590versions of perl prior to 5.6. F<t/5005-lib.pm> attempts to work around 591this to provide some basic testing of functionality. 592 593=item Support for TOIlet fonts 594 595Although the FIGlet font specification is not clear on the matter, 596convention dictates that there be no trailing whitespace after the 597end of line marker. Unfortunately some auto-generated TOIlet fonts 598break with this convention, while also lacking critical hardspaces. 599To fix these fonts, unzip then run C<perl -pi~ -e 's/@ $/$\@/'> on them. 600 601=back 602 603=head2 Unicode 604 605=over 606 607=item Pre-5.8 608 609Perl 5.6 Unicode support was notoriously sketchy. Best efforts have 610been made to work around this, and things should work fine. If you 611have problems, favor C<"\x{...}"> over C<chr>. See also L<Text::FIGlet/NOTES> 612 613=item Pre-5.6 614 615Text::FIGlet B<does> provide limited support for Unicode in perl 5.005. 616It understands "literal Unicode characters" (UTF-8 sequences), and will 617emit the correct output if the loaded font supports it. It does not 618support negative character mapping at this time. 619See also L<Text::FIGlet/NOTES> 620 621=item Negative character codes 622 623There is limited support for negative character codes, 624at this time only characters -2 through -65_535 are supported. 625 626=back 627 628=head2 Memory 629 630The standard font is 4Mb with no optimizations. 631 632Listed below are increasingly severe means of reducing memory use when 633creating an object. 634 635=over 636 637=item B<-U=E<gt>-1> 638 639This loads Unicode fonts, but skips negative characters. It's the default. 640 641The standard font is 68kb with this optimization. 642 643=item B<-U=E<gt>0> 644 645This only loads ASCII characters; plus the Deutsch characters if -D is true. 646 647The standard font is 14kb with this optimization. 648 649=back 650 651=head1 AUTHOR 652 653Jerrad Pierce 654 655 ** />> 656 _ // _ _ _ / >>> 657 (_) ** ,adPPYba, >< ><<< _(_)(_)(_) / >>> 658 | | /** a8P_____88 ><< (_) >> >>> 659 | | |~~\ /** 8PP""""""" ><< (_) >>>>>>>> 660 _/ | |__/ /** "8b, ,aa ><< (_)_ _ _ >>>>>>> @cpan.org 661 |__/ | /** `"Ybbd8"' ><<< (_)(_)(_) >> 662 // >>>> / 663 >>>>>>/ 664 >>>>> 665 666=cut 667