File Coverage

blib/lib/Term/Table/Util.pm
Criterion Covered Total %
statement 23 23 100.0
branch 3 4 75.0
condition n/a
subroutine 8 8 100.0
pod 0 1 0.0
total 34 36 94.4


line stmt bran cond sub pod time code
1             package Term::Table::Util;
2 7     7   90208 use strict;
  7         21  
  7         203  
3 7     7   34 use warnings;
  7         22  
  7         217  
4              
5 7     7   36 use Config qw/%Config/;
  7         18  
  7         421  
6              
7             our $VERSION = '0.017';
8              
9 7     7   59 use base 'Exporter';
  7         10  
  7         1402  
10             our @EXPORT_OK = qw/term_size USE_GCS USE_TERM_READKEY USE_TERM_SIZE_ANY uni_length/;
11              
12             sub DEFAULT_SIZE() { 80 }
13              
14             my $IO;
15             BEGIN {
16 7 50   7   8051 open($IO, '>&', *STDOUT) or die "Could not clone STDOUT";
17             }
18              
19             sub try(&) {
20 21     21 0 44 my $code = shift;
21 21         251 local ($@, $?, $!);
22 21         43 my $ok = eval { $code->(); 1 };
  21         47  
  14         220810  
23 21         61 my $err = $@;
24 21         119 return ($ok, $err);
25             }
26              
27             my ($tsa) = try { require Term::Size::Any; Term::Size::Any->import('chars') };
28             my ($trk) = try { require Term::ReadKey };
29             $trk &&= Term::ReadKey->can('GetTerminalSize');
30              
31             if (!-t $IO) {
32             *USE_TERM_READKEY = sub() { 0 };
33             *USE_TERM_SIZE_ANY = sub() { 0 };
34             *term_size = sub {
35 3 100   3   975 return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
36 2         13 return DEFAULT_SIZE;
37             };
38             }
39             elsif ($tsa) {
40             *USE_TERM_READKEY = sub() { 0 };
41             *USE_TERM_SIZE_ANY = sub() { 1 };
42             *_term_size = sub {
43             my $size = chars($IO);
44             return DEFAULT_SIZE if !$size;
45             return DEFAULT_SIZE if $size < DEFAULT_SIZE;
46             return $size;
47             };
48             }
49             elsif ($trk) {
50             *USE_TERM_READKEY = sub() { 1 };
51             *USE_TERM_SIZE_ANY = sub() { 0 };
52             *_term_size = sub {
53             my $total;
54             try {
55             my @warnings;
56             {
57             local $SIG{__WARN__} = sub { push @warnings => @_ };
58             ($total) = Term::ReadKey::GetTerminalSize($IO);
59             }
60             @warnings = grep { $_ !~ m/Unable to get Terminal Size/ } @warnings;
61             warn @warnings if @warnings;
62             };
63             return DEFAULT_SIZE if !$total;
64             return DEFAULT_SIZE if $total < DEFAULT_SIZE;
65             return $total;
66             };
67             }
68             else {
69             *USE_TERM_READKEY = sub() { 0 };
70             *USE_TERM_SIZE_ANY = sub() { 0 };
71             *term_size = sub {
72             return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
73             return DEFAULT_SIZE;
74             };
75             }
76              
77             if (USE_TERM_READKEY() || USE_TERM_SIZE_ANY()) {
78             if (index($Config{sig_name}, 'WINCH') >= 0) {
79             my $changed = 0;
80             my $polled = -1;
81             $SIG{WINCH} = sub { $changed++ };
82              
83             my $size;
84             *term_size = sub {
85             return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
86              
87             unless ($changed == $polled) {
88             $polled = $changed;
89             $size = _term_size();
90             }
91              
92             return $size;
93             }
94             }
95             else {
96             *term_size = sub {
97             return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
98             _term_size();
99             };
100             }
101             }
102              
103             my ($gcs, $err) = try { require Unicode::GCString };
104              
105             if ($gcs) {
106             *USE_GCS = sub() { 1 };
107 3406     3406   6721 *uni_length = sub { Unicode::GCString->new($_[0])->columns };
108             }
109             else {
110             *USE_GCS = sub() { 0 };
111             *uni_length = sub { length($_[0]) };
112             }
113              
114             1;
115              
116             __END__