Text::FIGlet::Font - text generation for Text::FIGlet

  use Text::FIGlet;

  my $font = Text::FIGlet->new(-f=>"doh");

  print ~~$font->figify(-A=>"Hello World");

  ftp://ftp.figlet.org/pub/figlet/

                **                                    />>
     _         //                         _  _  _    / >>>
    (_)         **  ,adPPYba,  >< ><<<  _(_)(_)(_)  /   >>>
    | |        /** a8P_____88   ><<    (_)         >>    >>>
    | |  |~~\  /** 8PP"""""""   ><<    (_)         >>>>>>>>
   _/ |  |__/  /** "8b,   ,aa   ><<    (_)_  _  _  >>>>>>> @cpan.org
  |__/   |     /**  `"Ybbd8"'  ><<<      (_)(_)(_) >>  
               //                                  >>>>    /
                                                    >>>>>>/
                                                     >>>>>

package Text::FIGlet::Font;
use strict;
use vars qw($REwhite $VERSION);
use Carp qw(cluck confess);
use Symbol; #5.005 support
use Text::Wrap;
$VERSION = 2.18;

#'import' core support functions from parent with circular dependency
foreach( qw/UTF8len UTF8ord _canonical _no/){
  no strict 'refs';
  *$_ = *{'Text::FIGlet::'.$_};
}


sub new{
  shift();
  my $self = {_maxLen=>0, -U=>-1, -m=>-2, @_};
  $self->{-m} = -3 if defined($self->{-m}) && $self->{-m} eq '-0';
  $self->{-f} ||= $ENV{FIGFONT} || 'standard';
  $self->{-d} ||= $ENV{FIGLIB}  || '/usr/games/lib/figlet/';
  _load_font($self);
  bless($self);
}

sub _load_font{
  my $self = shift();
  my $font = $self->{_font} = [];
  my(@header, $header, $path, $ext);
  local($_);

#MAGIC minifig0
  $self->{_file} = _canonical($self->{-d}, $self->{-f}, qr/\.[ft]lf/,
			      $^O =~ /MSWin32|DOS/i);
  #XXX bsd_glob .[ft]lf
  $self->{_file} = (glob($self->{_file}.'.?lf'))[0] unless -e $self->{_file};


  #open(FLF, $self->{_file}) || confess("$!: $self->{_file}");
  $self->{_fh} = gensym;            #5.005 support
  eval "use IO::Uncompress::Unzip"; #XXX sniff for 'PK\003\004'instead?
  unless( $@ ){
      $self->{_fh} = eval{ IO::Uncompress::Unzip->new($self->{_file}) } ||
	  confess("No such file or directory: $self->{_file}");
  }
  else{
      open($self->{_fh}, '<'.$self->{_file}) || confess("$!: $self->{_file}");
      #$^W isn't mutable at runtime in 5.005, so we have to conditional eval
      #to avoid "Useless use of constant in void context"
      eval "binmode(\$fh, ':encoding(utf8)')" unless $] < 5.006;
  }
#MAGIC minifig1

  my $fh = $self->{_fh};  #5.005 support
  chomp($header = <$fh>); #5.005 hates readline & $self->{_fh} :-/
  confess("Invalid FIGlet 2/TOIlet font") unless $header =~ /^[ft]lf2/;

  #flf2ahardblank height up_ht maxlen smushmode cmt_count rtol
  @header = split(/\s+/, $header);
  $header[0] =~ s/^[ft]lf2.//;
  #$header[0] = qr/@{[sprintf "\\%o", ord($header[0])]}/;
  $header[0] = quotemeta($header[0]);
  $self->{_header} = \@header;

  if( defined($self->{-m}) && $self->{-m} eq '-2' ){
    $self->{-m} = $header[4];
  }

  #Discard comments
  <$fh> for 1 .. $header[5] || cluck("Unexpected end of font file") && last;

  #Get ASCII characters
  foreach my $i(32..126){
    &_load_char($self, $i) || last;
  }

  #German characters?
  unless( eof($fh) ){
    my %D =(91=>196, 92=>214, 93=>220, 123=>228, 124=>246, 125=>252, 126=>223);

    foreach my $k ( sort {$a <=> $b} keys %D ){
      &_load_char($self, $D{$k}) || last;
    }
    if( $self->{-D} ){
      $font->[$_] = $font->[$D{$_}] for keys %D;
      #removal is necessary to prevent 2nd reference to same figchar,
      #which would then become over-smushed; alas 5.005 can't delete arrays
      $#{$font} = 126; #undef($font->[$_]) for values %D;
    }
  }

  #ASCII bypass
  close($fh) unless $self->{-U};

  #Extended characters, with extra readline to get code
  until( eof($fh) ){
    $_ = <$fh> || cluck("Unexpected end of font file") && last;
    
    /^\s*$Text::FIGlet::RE{no}/;
    last unless $2;
    my $val = _no($1, $2, $3, 1);
    
    #Bypass negative chars?
    if( $val > Text::FIGlet->PRIVb && $self->{-U} == -1 ){
      readline($fh) for 0..$self->{_header}->[1]-1;
    }
    else{
      #Clobber German chars
      $font->[$val] = '';
      &_load_char($self, $val) || last;
    }
  }
  close($fh);


  #monospace
  if( defined($self->{-m}) && $self->{-m} == -3 ){
    my $pad;
    for(my $ord=0; $ord < scalar @{$font}; $ord++){
      next unless defined $font->[$ord];
      foreach my $i (-$header[1]..-1){
        #next unless exists($font->[$ord]->[2]); #55compat
        next unless defined($font->[$ord]->[2]);

	# The if protects from a a 5.6(.0)? bug
	$font->[$ord]->[$i] =~ s/^\s{1,$font->[$ord]->[1]}//
	  if $font->[$ord]->[1];

  	$pad = $self->{_maxLen} - UTF8len($font->[$ord]->[$i]);
#  	print STDERR "$pad = $self->{_maxLen} - UTF8len($font->[$ord]->[$i]);\n";
  	$font->[$ord]->[$i] = " " x int($pad/2) .
  	  $font->[$ord]->[$i] . " " x ($pad-int($pad/2));
      }
    }
  }
  #fullwidth
  elsif( defined($self->{-m}) && $self->{-m} == -1 ){
    for(my $ord=32; $ord < scalar @{$font}; $ord++){
      next unless defined $font->[$ord];
      foreach my $i (-$header[1]..-1){
	next unless $font->[$ord]->[$i];
	# The if protects from a a 5.6(.0)? bug
	$font->[$ord]->[$i] =~ s/^\s{1,$font->[$ord]->[1]}//
	  if $font->[$ord]->[1];
        substr($font->[$ord]->[$i], 0, 0, ' 'x$font->[$ord]->[1]);
        $font->[$ord]->[$i] .= ' 'x$font->[$ord]->[2];
      }
    }
  }
  #smush...
  elsif( !defined($self->{-m}) || $self->{-m} > -1 ){
    for(my $ord=32; $ord < scalar @{$font}; $ord++){
      next unless defined $font->[$ord];
      foreach my $i (-$header[1]..-1){
	next unless $font->[$ord]->[$i];
	# The if protects from a a 5.6(.0)? bug
	$font->[$ord]->[$i] =~ s/^\s{1,$font->[$ord]->[1]}//
	  if $font->[$ord]->[1];
      }
    }
  }
}


sub _load_char{
  my($self, $i) = @_;
  my $font = $self->{_font};
  my($length, $wLead, $wTrail, $end, $line, $l) = 0;
  
  $wLead = $wTrail = $self->{_header}->[3];

  my $fh = $self->{_fh}; #5.005 support
  
  my $REtrail;
  foreach my $j (0..$self->{_header}->[1]-1){
    $line = $_ = <$fh> ||
      cluck("Unexpected end of font file") && return 0;
    #This is the end.... this is the end my friend
    unless( $REtrail ){
      /(.)\s*$/;
      $end = $1;
      #The negative leading anchor is for term 0x40
      #$REtrail = qr/(?<!^)([ $self->{_header}->[0]]+)\Q$end$end\E?\s*$/;
      $REtrail = qr/(?<!^)([ $self->{_header}->[0]]+)\Q$end{1,2}\E?\s*$/;
    }
    if( $wLead && s/^(\s+)// ){
      $wLead  = $l if ($l = length($1)) < $wLead;
    }
    else{
      $wLead  = 0;
    }
    if( $wTrail && /$REtrail/ ){
      $wTrail = $l if ($l = length($1)) < $wTrail;
    }
    else{
      $wTrail = 0;
    }
    $length = $l if ($l =                    UTF8len($_)
		     -(s/(\Q$end\E+)$/$end/&&UTF8len($1))  ) > $length;
    $font->[$i] .= $line;
  }
  #XXX :-/ stop trying at 125 in case of map in ~ or extended....
  $self->{_maxLen} = $length if $i < 126 && $self->{_maxLen} < $length;

  #Ideally this would be /o but then all figchar's must have same EOL
  $font->[$i] =~ s/\015|\Q$end\E{1,2}\r?$//mg;
  $font->[$i] = [$length,#maxLen
		 $wLead, #wLead
		 $wTrail,#wTrail
		 split(/\r|\r?\n/, $font->[$i])];
  return 1;
}


sub figify{
    my $self = shift();
    my $font = $self->{_font};
    my %opts = (-A=>'', -X=>'', -x=>'', -w=>'', -U=>0, @_);
    my @buffer;
    local $_;

    $opts{-w} ||= 80;
    &Encode::_utf8_off($opts{-A}) if $] >= 5.008;

    #Do text formatting here...
    $opts{-X} ||= $self->{_header}->[6] ? 'R' : 'L';
    if( $opts{-X} eq 'R' ){
	$opts{-A} = join('', reverse(split('', $opts{-A})));
    }

    $opts{-A} =~ y/\t/ /;
    $opts{-A} =~ s%$/%\n% unless $/ eq "\n";
    if( defined($self->{-m}) && $self->{-m} == -3 ){
	$Text::Wrap::columns = int($opts{-w} / $self->{_maxLen})+1;
	$Text::Wrap::columns =2 if $Text::Wrap::columns < 2;
	$opts{-A} = Text::Wrap::wrap('', '', $opts{-A});
    }
    #No-wrap test, missing pre 2.00 :-(
    elsif( $opts{-w} > 0 ){
	$Text::Wrap::columns = $opts{-w}+1;
	unless( $opts{-w} == 1 ){
	  ($_, $opts{-A}) = ($opts{-A}, '');
#	  $opts{-A} .= "\0"x(($font->[ ord($1) ]->[0]||1)-1) . $1 while /(.)/g;
	  while( $opts{-U} ?
		 /$Text::FIGlet::RE{UTFchar}/g :
		 /$Text::FIGlet::RE{bytechar}/g ){
	    $opts{-A} .= "\0"x(($font->[
					$opts{-U} ? UTF8ord($1) : ord($1)
				]->[0]||1)-1) . $1;
	  }
	}
	#XXX pre 5.8 Text::Wrap is not Unicode happy?
        $opts{-A} = Text::Wrap::wrap('', '', $opts{-A});
	$opts{-A} =~ tr/\0//d;
    }

    my $X = defined($self->{-m}) ? '' : "\000";

    foreach( split("\n", $opts{-A}) ){
      my @lchars;
      s/^\s*//o; #XXX
#      push(@lchars, ord $1) while /(.)/g;
      while( $opts{-U} ?
	     /$Text::FIGlet::RE{UTFchar}/g :
	     /$Text::FIGlet::RE{bytechar}/g ){
	push @lchars, ($opts{-U} ? UTF8ord($1) : ord($1));
      }

      foreach my $i (-$self->{_header}->[1]..-1){
	my $line='';
	foreach my $lchar (@lchars){
	  if( $font->[$lchar] ){
	    $line .= $X . $font->[$lchar]->[$i] if $font->[$lchar]->[$i];
	  }
	  else{
	    $line .= $X . $font->[32]->[$i];
	  }
	}

	#$self->{_header}->[0] = qr/@{[sprintf "\\%o", ord($self->{_header}->[0])]}/;

	#Do some more text formatting here... (smushing?)
	$opts{-x} ||= $opts{-X} eq 'R' ? 'r' : 'l';
	if( $opts{-x} eq 'c' ){
	  $line = " "x(($opts{-w}-length($line))/2) . $line;
	}
	if( $opts{-x} eq 'r' ){
	  $line = " "x($opts{-w}-length($line)) . $line;
	}

	#Replace hardblanks
	$line =~ s/$self->{_header}->[0]/ /g;
	
	push @buffer, $line;
      }
    }

    #Overlap
    if( $X ){
	foreach( @buffer ){
	    s/^\000|\000 //g;
	    s/$Text::FIGlet::RE{UTFchar}\000//g;
	}
    }

    #Properly promote (back) to utf-8
    eval "use encoding  'utf-8'";
    return wantarray ? map{Encode::_utf8_on($_)} @buffer : Encode::_utf8_on($_=join($/, @buffer).$/),$_ unless $] < 5.006;


    return wantarray ? @buffer : join($/, @buffer).$/;
}
1;
__END__