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


line stmt bran cond sub pod time code
1             package Text::FIGlet;
2 4     4   217436 use strict;
  4         9  
  4         181  
3 4     4   22 use vars qw'$VERSION %RE';
  4         8  
  4         334  
4             $VERSION = '2.19.3'; #Actual code version: 2.19.1
5              
6             #~50us penalty w/ 2 constant calls for 5.005
7 4     4   25 use constant PRIVb => 0xF0000; #Map neg chars into Unicode's private area
  4         12  
  4         1058  
8 4     4   24 use constant PRIVe => 0xFFFFD; #0-31 are also available but unused.
  4         6  
  4         211  
9 4     4   21 use Carp qw(carp croak);
  4         8  
  4         851  
10 4     4   26 use File::Spec;
  4         8  
  4         121  
11 4     4   23 use File::Basename 'fileparse';
  4         7  
  4         559  
12 4     4   3033 use Text::FIGlet::Control;
  4         18  
  4         116  
13 4     4   3026 use Text::FIGlet::Font;
  4         15  
  4         179  
14 4     4   2857 use Text::FIGlet::Ransom;
  4         13  
  4         1018  
15              
16              
17             if( $] >= 5.008 ){
18             require Encode; #Run-time rather than compile-time, without an eval
19             import Encode;
20 21     21   130 eval 'sub _utf8_on {Encode::decode("utf8",shift)}';
21             # sub _utf8_off {Encode::_utf8_off(@_)}';
22             } #Next block from Encode::compat, but broadened from 5.6.1 to 5.6
23             elsif ($] >= 5.006 and $] <= 5.007) {
24             eval 'sub _utf8_on { $_[0] = pack("U*", unpack("U0U*", $_[0])) }
25             sub Encode::_utf8_off { $_[0] = pack("C*", unpack("C*", $_[0])) }';
26             }
27             else{
28             local $^W = 0;
29             eval "sub _utf8_on{}; sub Encode::_utf8_off{};";
30             }
31              
32              
33             my $thByte = '[\x80-\xBF]';
34             %RE = (
35             #XXX Should perhaps put 1 byte UTF-8 last as . instead, to catch ANSI
36             #XXX Alas that catches many other unfortunate things...
37             UTFchar => qr/([\x20-\x7F]|[\xC2-\xDF]$thByte|[\xE0-\xEF]$thByte{2}|[\xF0-\xF4]$thByte{3})/,
38             bytechar=> qr/(.)/s,
39             no => qr/(-?)((0?)(?:x[\da-fA-F]+|\d+))/,
40             );
41              
42              
43             sub import{
44 4 50   4   65 @_ = qw/UTF8chr UTF8ord UTF8len/ if grep(/:Encode/, @_);
45              
46 4 50       20 if( @_ ) {
47 4     4   25 no strict 'refs';
  4         9  
  4         4351  
48 4         9266 *{scalar(caller).'::'.$_} = $_ for grep/UTF8chr|UTF8ord|UTF8len/, @_;
  0         0  
49             }
50             }
51              
52              
53             sub new {
54 15     15 0 19240 local $_;
55 15         34 my $proto = shift;
56 15         67 my %opt = @_;
57 15         31 my($class, @isect, %count);
58 15         71 my %class = (-f => 'Font', -C => 'Control');
59              
60              
61 15 100       103 if( ref($opt{-f}) =~ /ARRAY|HASH/ ){
62 4         10 $class = 'Text::FIGlet::Ransom';
63             }
64             else{
65 11         82 $count{$_}++ for (keys %opt, keys %class);
66 11   66     108 $count{$_} == 2 && push(@isect, $_) for keys %count;
67 11 50       49 croak("Cannot new both -C and -f") if scalar @isect > 1;
68 11   100     76 $class = 'Text::FIGlet::' . $class{shift(@isect) || '-f'};
69             }
70 15         163 $class->new(@_);
71             }
72              
73              
74             sub UTF8chr{
75 0   0 0 0 0 my $ord = shift || $_;
76 0         0 my @n;
77              
78             #x00-x7f #1 byte
79 0 0       0 if( $ord < 0x80 ){
    0          
    0          
    0          
80 0         0 @n = $ord; }
81             #x80-x7ff #2 bytes
82             elsif( $ord < 0x800 ){
83 0         0 @n = (0xc0|$ord>>6, 0x80|$ord&0x3F ); }
84             #x800-xffff #3 bytes
85             elsif( $ord < 0x10000 ){
86 0         0 @n = (0xe0|$ord>>12,
87             0x80|($ord>>6)&0x3F,
88             0x80|$ord&0x3F ); }
89             #x10000-x10ffff #4 bytes
90             elsif( $ord<0x20000 ){
91 0         0 @n = (0xf0|$ord>>18,
92             0x80|($ord>>12)&0x3F,
93             0x80|($ord>>6)&0x3F,
94             0x80|$ord&0x3F); }
95             else{
96 0         0 warn "Out of range for UTF-8: $ord"; }
97              
98 0         0 return pack "C*", @n;
99             }
100              
101              
102             sub UTF8len{
103 38944   66 38944 0 117762 my $str = shift || $_;
104 38944         606201 my $count = () = $str =~ m/$Text::FIGlet::RE{UTFchar}/g;
105             }
106              
107              
108             sub UTF8ord{
109 10   33 10 0 42 my $str = shift || $_;
110 10         15 my $len = length ($str);
111              
112 10 50       24 return ord($str) if $len == 1;
113             #This is a FIGlet specific error value
114 10 50 33     54 return 128 if $len > 4 || $len == 0;
115              
116 10         2275 my @n = unpack "C*", $str;
117 10         21 $str = (($n[-2] & 0x3F) << 6) + ($n[-1] & 0x3F);
118 10 50       28 $str += (($n[-3] & 0x1F) << 12) if $len ==3;
119 10 100       22 $str += (($n[-3] & 0x3F) << 12) if $len ==4;
120 10 100       24 $str += (($n[-4] & 0x0F) << 18) if $len == 4;
121 10         108 return $str;
122             }
123              
124              
125             sub _no{
126 1652     1652   4580 my($one, $two, $thr, $over) = @_;
127              
128 1652 100       6221 my $val = ($one ? -1 : 1) * ( $thr eq 0 ? oct($two) : $two);
    100          
129              
130             #+2 is to map -2 to offset zero (-1 is forbidden, modern systems have no -0)
131 1652 100       3210 $val += PRIVe + 2 if $one;
132 1652 50 100     3744 if( $one && $over && $val < PRIVb ){
      66        
133 0         0 carp("Extended character out of bounds");
134 0         0 return 0;
135             }
136              
137 1652         4214 $val;
138             }
139              
140              
141             sub _canonical{
142 19     19   72 my($defdir, $usrfile, $extre, $backslash) = @_;
143 19 50       958 return -e $usrfile ? $usrfile :
144             File::Spec->catfile($defdir, $usrfile);
145              
146             #Dragons be here, was for pseudo-Windows tests/old Perls?
147              
148             #Split things up
149 0           my($file, $path, $ext) = fileparse($usrfile, $extre);
150              
151 0 0         $path =~ y/\\/\// if $backslash;
152              
153             #Handle paths relative to current directory
154 0           my $curdir = File::Spec->catfile(File::Spec->curdir, "");
155 0 0 0       $path = $defdir if $path eq $curdir && index($usrfile, $curdir) < 0;
156              
157              
158             #return canonicaled path
159 0           return File::Spec->catfile($path, $file.$ext);
160             }
161              
162             local $_="Act kind of random and practice less beauty sense --ginoh";
163              
164             __END__