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