File Coverage

blib/lib/Text/FIGlet.pm

Criterion	Covered	Total	%
statement	68	85	80.0
branch	20	40	50.0
condition	13	26	50.0
subroutine	18	19	94.7
pod	0	4	0.0
total	119	174	68.3

package Text::FIGlet;
use strict;
use vars qw'$VERSION %RE';
$VERSION = '2.19.4';           #Actual code version: 2.19.1

                               #~50us penalty w/ 2 constant calls for 5.005
use constant PRIVb => 0xF0000; #Map neg chars into Unicode's private area
use constant PRIVe => 0xFFFFD; #0-31 are also available but unused.
use Carp qw(carp croak);
use File::Spec;
use File::Basename 'fileparse';
use Text::FIGlet::Control;
use Text::FIGlet::Font;
use Text::FIGlet::Ransom;


if( $] >= 5.008 ){
    require Encode; #Run-time rather than compile-time, without an eval
    import Encode;
    eval 'sub _utf8_on  {Encode::decode("utf8",shift)}';
#          sub _utf8_off {Encode::_utf8_off(@_)}';
}   #Next block from Encode::compat, but broadened from 5.6.1 to 5.6
elsif ($] >= 5.006 and $] <= 5.007) {
    eval 'sub _utf8_on  { $_[0] = pack("U*", unpack("U0U*", $_[0])) }
          sub Encode::_utf8_off { $_[0] = pack("C*", unpack("C*",   $_[0])) }';
}
else{
    local $^W = 0;
    eval "sub _utf8_on{}; sub Encode::_utf8_off{};";
}


my $thByte = '[\x80-\xBF]';
%RE = (
       #XXX Should perhaps put 1 byte UTF-8 last as . instead, to catch ANSI
       #XXX Alas that catches many other unfortunate things...
       UTFchar => qr/([\x20-\x7F]|[\xC2-\xDF]$thByte|[\xE0-\xEF]$thByte{2}|[\xF0-\xF4]$thByte{3})/,
       bytechar=> qr/(.)/s,
       no      => qr/(-?)((0?)(?:x[\da-fA-F]+|\d+))/,
       );


sub import{
  @_ = qw/UTF8chr UTF8ord UTF8len/ if grep(/:Encode/, @_);

  if( @_ ) {
    no strict 'refs';
    *{scalar(caller).'::'.$_} = $_ for grep/UTF8chr|UTF8ord|UTF8len/, @_;
  }
}


sub new {
  local $_;
  my $proto = shift;
  my %opt = @_;
  my($class, @isect, %count);
  my %class = (-f => 'Font', -C => 'Control');


  if( ref($opt{-f}) =~ /ARRAY|HASH/ ){
      $class = 'Text::FIGlet::Ransom';
  }
  else{
      $count{$_}++ for (keys %opt, keys %class);
      $count{$_} == 2 && push(@isect, $_) for keys %count;
      croak("Cannot new both -C and -f") if scalar @isect > 1;
      $class = 'Text::FIGlet::' . $class{shift(@isect) || '-f'};
  }
  $class->new(@_);
}


sub UTF8chr{
  my $ord = shift || $_;
  my @n;

  #x00-x7f        #1 byte
  if( $ord < 0x80 ){
    @n = $ord; }
  #x80-x7ff       #2 bytes
  elsif( $ord < 0x800 ){
    @n  = (0xc0|$ord>>6, 0x80|$ord&0x3F ); }
  #x800-xffff     #3 bytes
  elsif( $ord < 0x10000 ){
    @n  = (0xe0|$ord>>12,
	   0x80|($ord>>6)&0x3F,
	   0x80|$ord&0x3F ); }
  #x10000-x10ffff #4 bytes
  elsif( $ord<0x20000 ){
    @n = (0xf0|$ord>>18,
	  0x80|($ord>>12)&0x3F,
	  0x80|($ord>>6)&0x3F,
	  0x80|$ord&0x3F); }
  else{
    warn "Out of range for UTF-8: $ord"; }

  return pack "C*", @n;
}


sub UTF8len{
  my $str = shift || $_;
  my $count = () = $str =~ m/$Text::FIGlet::RE{UTFchar}/g;
}


sub UTF8ord{
  my $str = shift || $_;
  my $len = length ($str);

  return ord($str) if $len == 1;
  #This is a FIGlet specific error value
  return 128       if $len > 4 || $len == 0;

  my @n = unpack "C*", $str;
  $str  = (($n[-2] & 0x3F) <<  6) + ($n[-1] & 0x3F);
  $str += (($n[-3] & 0x1F) << 12) if $len ==3;
  $str += (($n[-3] & 0x3F) << 12) if $len ==4;
  $str += (($n[-4] & 0x0F) << 18) if $len == 4;
  return $str;
}


sub _no{
  my($one, $two, $thr, $over) = @_;

  my $val = ($one ? -1 : 1) * ( $thr eq 0 ? oct($two) : $two);

  #+2 is to map -2 to offset zero (-1 is forbidden, modern systems have no -0)
  $val += PRIVe + 2 if $one;
  if( $one && $over && $val < PRIVb ){
    carp("Extended character out of bounds");
    return 0;
  }

  $val;
}


sub _canonical{
  my($defdir, $usrfile, $extre, $backslash) = @_;
  return -e $usrfile ? $usrfile :
      File::Spec->catfile($defdir, $usrfile);

  #Dragons be here, was for pseudo-Windows tests/old Perls?

  #Split things up
  my($file, $path, $ext) = fileparse($usrfile, $extre);

  $path =~ y/\\/\// if $backslash;

  #Handle paths relative to current directory
  my $curdir = File::Spec->catfile(File::Spec->curdir, "");
  $path = $defdir if $path eq $curdir && index($usrfile, $curdir) < 0;


  #return canonicaled path
  return File::Spec->catfile($path, $file.$ext);
}

local $_="Act kind of random and practice less beauty sense --ginoh";

__END__