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

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.19.3';

#'import' core support functions from parent with circular dependency
foreach( qw/UTF8len UTF8ord _canonical _no _utf8_on/){
  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);


  #Fixed width
  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));
      }
    }
  }
  #Full width
  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];
      }
    }
  }
  #Kern glyph boxes
  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.flf 0x40
      $REtrail = qr/(?{_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 charmap 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}\s*\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;

    #Prepare the input
    $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});
	&Encode::_utf8_off($opts{-A}) if $] >= 5.008;
    }
    elsif( $opts{-w} > 0 ){
	&Encode::_utf8_off($opts{-A}) if $] >= 5.008;
	$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;
    }

    #Assemble glyphs
    my $X = defined($self->{-m}) && $self->{-m} < 0 ? '' : "\000";
    foreach( split("\n", $opts{-A}) ){
      my(@lchars, @lines);
      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 .= $font->[$lchar]->[$i] . $X if $font->[$lchar]->[$i];
	  }
	  else{
	    $line .= $font->[32]->[$i] . $X;
	  }
	}

	$line =~ s/\000$//;
	push @lines, $line;
      }

      #Kern glyphs?
      if( !defined($self->{-m}) || $self->{-m} > -1 ){
	for(my $nulls = 0; $nulls < scalar @lchars ; $nulls++){
	  my $matches = 0;
	  my @temp;
	  for(my $i=0; $i
	    $matches += ($temp[$i] = $lines[$i]) =~
	      s/^([^\000]*(?:\000[^\000]*){$nulls})(?: \000|\000(?: |\Z))/$1\000/;

	    #($_ = $temp[$i]) =~ s/(${stem}{$nulls})/$1@/;
	    #print "$nulls, $i) $matches == @{[scalar @lines]} #$_\n";
	    if( $i == scalar(@lines)-1 && $matches == scalar @lines ){
	      @lines = @temp;
	      $matches = 0;
	      $i = -1;
	    }
	  }
	}
      }

      push @buffer, @lines;
    }


    #Layout
    $opts{-x} ||= $opts{-X} eq 'R' ? 'r' : 'l';
    foreach my $line (@buffer){
      #Smush
      if( !defined($self->{-m}) || $self->{-m} > 0 ){


	#Universal smush/overlap
	$line =~ s/\000 //g;
	$line =~ s/$Text::FIGlet::RE{UTFchar}\000//g;
      }
      else{
	$line =~ y/\000//d;
      }

      #Alignment
      if( $opts{-x} eq 'c' ){
	$line = " "x(($opts{-w}-UTF8len($line))/2) . $line;
      }
      elsif( $opts{-x} eq 'r' ){
	$line = " "x($opts{-w}-UTF8len($line)) . $line;
      }

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


    if( $] < 5.006 ){
	return wantarray ? @buffer : join($/, @buffer).$/;
    }
    else{
	#Properly promote (back) to utf-8
	return wantarray ? map{_utf8_on($_)} @buffer :
	    _utf8_on($_=join($/, @buffer).$/);
    }


}
1;
__END__