1package Term::Table::Util;
2use strict;
3use warnings;
4
5use Config qw/%Config/;
6
7our $VERSION = '0.018';
8
9use base 'Exporter';
10our @EXPORT_OK = qw/term_size USE_GCS USE_TERM_READKEY USE_TERM_SIZE_ANY uni_length/;
11
12sub DEFAULT_SIZE() { 80 }
13
14my $IO;
15BEGIN {
16    open($IO, '>&', *STDOUT) or die "Could not clone STDOUT";
17}
18
19sub try(&) {
20    my $code = shift;
21    local ($@, $?, $!);
22    my $ok = eval { $code->(); 1 };
23    my $err = $@;
24    return ($ok, $err);
25}
26
27my ($tsa) = try { require Term::Size::Any; Term::Size::Any->import('chars') };
28my ($trk) = try { require Term::ReadKey };
29$trk &&= Term::ReadKey->can('GetTerminalSize');
30
31if (!-t $IO) {
32    *USE_TERM_READKEY  = sub() { 0 };
33    *USE_TERM_SIZE_ANY = sub() { 0 };
34    *term_size         = sub {
35        return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
36        return DEFAULT_SIZE;
37    };
38}
39elsif ($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}
49elsif ($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}
68else {
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
77if (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
103my ($gcs, $err) = try { require Unicode::GCString };
104
105if ($gcs) {
106    *USE_GCS    = sub() { 1 };
107    *uni_length = sub   { Unicode::GCString->new($_[0])->columns };
108}
109else {
110    *USE_GCS    = sub() { 0 };
111    *uni_length = sub   { length($_[0]) };
112}
113
1141;
115
116__END__
117
118=pod
119
120=encoding UTF-8
121
122=head1 NAME
123
124Term::Table::Util - Utilities for Term::Table.
125
126=head1 DESCRIPTION
127
128This package exports some tools used by Term::Table.
129
130=head1 EXPORTS
131
132=head2 CONSTANTS
133
134=over 4
135
136=item $bool = USE_GCS
137
138True if L<Unicode::GCString> is installed.
139
140=item $bool = USE_TERM_READKEY
141
142True if L<Term::ReadKey> is installed.
143
144=back
145
146=head2 UTILITIES
147
148=over 4
149
150=item $width = term_size()
151
152Get the width of the terminal.
153
154If the C<$TABLE_TERM_SIZE> environment variable is set then that value will be
155returned.
156
157This will default to 80 if there is no good way to get the size, or if the size
158is unreasonably small.
159
160If L<Term::ReadKey> is installed it will be used.
161
162=item $width = uni_length($string)
163
164Get the width (in columns) of the specified string. When L<Unicode::GCString>
165is installed this will work on unicode strings, otherwise it will just use
166C<length($string)>.
167
168=back
169
170=head1 SOURCE
171
172The source code repository for Term-Table can be found at
173F<http://github.com/exodist/Term-Table/>.
174
175=head1 MAINTAINERS
176
177=over 4
178
179=item Chad Granum E<lt>exodist@cpan.orgE<gt>
180
181=back
182
183=head1 AUTHORS
184
185=over 4
186
187=item Chad Granum E<lt>exodist@cpan.orgE<gt>
188
189=back
190
191=head1 COPYRIGHT
192
193Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
194
195This program is free software; you can redistribute it and/or
196modify it under the same terms as Perl itself.
197
198See F<http://dev.perl.org/licenses/>
199
200=cut
201