Initial Commit

database/perl/vendor/lib/Term/Table/Util.pm

@@ -0,0 +1,200 @@
+package Term::Table::Util;
+use strict;
+use warnings;
+
+use Config qw/%Config/;
+
+our $VERSION = '0.015';
+
+use Importer Importer => 'import';
+our @EXPORT_OK = qw/term_size USE_GCS USE_TERM_READKEY USE_TERM_SIZE_ANY uni_length/;
+
+sub DEFAULT_SIZE() { 80 }
+
+my $IO;
+BEGIN {
+    open($IO, '>&', STDOUT) or die "Could not clone STDOUT";
+}
+
+sub try(&) {
+    my $code = shift;
+    local ($@, $?, $!);
+    my $ok = eval { $code->(); 1 };
+    my $err = $@;
+    return ($ok, $err);
+}
+
+my ($tsa) = try { require Term::Size::Any; Term::Size::Any->import('chars') };
+my ($trk) = try { require Term::ReadKey };
+$trk &&= Term::ReadKey->can('GetTerminalSize');
+
+if (!-t $IO) {
+    *USE_TERM_READKEY  = sub() { 0 };
+    *USE_TERM_SIZE_ANY = sub() { 0 };
+    *term_size         = sub {
+        return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
+        return DEFAULT_SIZE;
+    };
+}
+elsif ($tsa) {
+    *USE_TERM_READKEY  = sub() { 0 };
+    *USE_TERM_SIZE_ANY = sub() { 1 };
+    *_term_size        = sub {
+        my $size = chars($IO);
+        return DEFAULT_SIZE if !$size;
+        return DEFAULT_SIZE if $size < DEFAULT_SIZE;
+        return $size;
+    };
+}
+elsif ($trk) {
+    *USE_TERM_READKEY  = sub() { 1 };
+    *USE_TERM_SIZE_ANY = sub() { 0 };
+    *_term_size        = sub {
+        my $total;
+        try {
+            my @warnings;
+            {
+                local $SIG{__WARN__} = sub { push @warnings => @_ };
+                ($total) = Term::ReadKey::GetTerminalSize($IO);
+            }
+            @warnings = grep { $_ !~ m/Unable to get Terminal Size/ } @warnings;
+            warn @warnings if @warnings;
+        };
+        return DEFAULT_SIZE if !$total;
+        return DEFAULT_SIZE if $total < DEFAULT_SIZE;
+        return $total;
+    };
+}
+else {
+    *USE_TERM_READKEY  = sub() { 0 };
+    *USE_TERM_SIZE_ANY = sub() { 0 };
+    *term_size         = sub {
+        return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
+        return DEFAULT_SIZE;
+    };
+}
+
+if (USE_TERM_READKEY() || USE_TERM_SIZE_ANY()) {
+    if (index($Config{sig_name}, 'WINCH') >= 0) {
+        my $changed = 0;
+        my $polled = -1;
+        $SIG{WINCH} = sub { $changed++ };
+
+        my $size;
+        *term_size = sub {
+            return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
+
+            unless ($changed == $polled) {
+                $polled = $changed;
+                $size = _term_size();
+            }
+
+            return $size;
+        }
+    }
+    else {
+        *term_size = sub {
+            return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
+            _term_size();
+        };
+    }
+}
+
+my ($gcs, $err) = try { require Unicode::GCString };
+
+if ($gcs) {
+    *USE_GCS    = sub() { 1 };
+    *uni_length = sub   { Unicode::GCString->new($_[0])->columns };
+}
+else {
+    *USE_GCS    = sub() { 0 };
+    *uni_length = sub   { length($_[0]) };
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Term::Table::Util - Utilities for Term::Table.
+
+=head1 DESCRIPTION
+
+This package exports some tools used by Term::Table.
+
+=head1 EXPORTS
+
+=head2 CONSTANTS
+
+=over 4
+
+=item $bool = USE_GCS
+
+True if L<Unicode::GCString> is installed.
+
+=item $bool = USE_TERM_READKEY
+
+True if L<Term::ReadKey> is installed.
+
+=back
+
+=head2 UTILITIES
+
+=over 4
+
+=item $width = term_size()
+
+Get the width of the terminal.
+
+If the C<$TABLE_TERM_SIZE> environment variable is set then that value will be
+returned.
+
+This will default to 80 if there is no good way to get the size, or if the size
+is unreasonably small.
+
+If L<Term::ReadKey> is installed it will be used.
+
+=item $width = uni_length($string)
+
+Get the width (in columns) of the specified string. When L<Unicode::GCString>
+is installed this will work on unicode strings, otherwise it will just use
+C<length($string)>.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Term-Table can be found at
+F<http://github.com/exodist/Term-Table/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut