GSP/Panel
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Added Cyg-Win

Browse source
This commit is contained in:
Frank Harris 2026-06-06 18:46:40 -04:00
parent 82cbc206eb
commit 413c315806
10586 changed files with 3806249 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

1414
Agent-Windows/OGP64/usr/share/perl5/5.40/Term/ANSIColor.pm Normal file
View file

File diff suppressed because it is too large Load diff

772
Agent-Windows/OGP64/usr/share/perl5/5.40/Term/Cap.pm Normal file
View file

@ -0,0 +1,772 @@
package Term::Cap;
# Since the debugger uses Term::ReadLine which uses Term::Cap, we want
# to load as few modules as possible. This includes Carp.pm.
sub carp
{
require Carp;
goto &Carp::carp;
}
sub croak
{
require Carp;
goto &Carp::croak;
}
use strict;
use vars qw($VERSION $VMS_TERMCAP);
use vars qw($termpat $state $first $entry);
$VERSION = '1.18';
# TODO:
# support Berkeley DB termcaps
# force $FH into callers package?
# keep $FH in object at Tgetent time?
=head1 NAME
Term::Cap - Perl termcap interface
=head1 SYNOPSIS
require Term::Cap;
$terminal = Term::Cap->Tgetent({ TERM => undef, OSPEED => $ospeed });
$terminal->Trequire(qw/ce ku kd/);
$terminal->Tgoto('cm', $col, $row, $FH);
$terminal->Tputs('dl', $count, $FH);
$terminal->Tpad($string, $count, $FH);
=head1 DESCRIPTION
These are low-level functions to extract and use capabilities from
a terminal capability (termcap) database.
More information on the terminal capabilities will be found in the
termcap manpage on most Unix-like systems.
=head2 METHODS
The output strings for B<Tputs> are cached for counts of 1 for performance.
B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
data and C<$self-E<gt>{xx}> is the cached version.
print $terminal->Tpad($self->{_xx}, 1);
B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
output the string to $FH if specified.
=cut
# Preload the default VMS termcap.
# If a different termcap is required then the text of one can be supplied
# in $Term::Cap::VMS_TERMCAP before Tgetent is called.
if ( $^O eq 'VMS' )
{
chomp( my @entry = <DATA> );
$VMS_TERMCAP = join '', @entry;
}
# Returns a list of termcap files to check.
sub termcap_path
{ ## private
my @termcap_path;
# $TERMCAP, if it's a filespec
push( @termcap_path, $ENV{TERMCAP} )
if (
( exists $ENV{TERMCAP} )
&& (
( $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' )
? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is
: $ENV{TERMCAP} =~ /^\//s
)
);
if ( ( exists $ENV{TERMPATH} ) && ( $ENV{TERMPATH} ) )
{
# Add the users $TERMPATH
push( @termcap_path, split( /:|\s+/, $ENV{TERMPATH} ) );
}
else
{
# Defaults
push( @termcap_path,
exists $ENV{'HOME'} ? $ENV{'HOME'} . '/.termcap' : undef,
'/etc/termcap', '/usr/share/misc/termcap', );
}
# return the list of those termcaps that exist
return grep { defined $_ && -f $_ } @termcap_path;
}
=over 4
=item B<Tgetent>
Returns a blessed object reference which the user can
then use to send the control strings to the terminal using B<Tputs>
and B<Tgoto>.
The function extracts the entry of the specified terminal
type I<TERM> (defaults to the environment variable I<TERM>) from the
database.
It will look in the environment for a I<TERMCAP> variable. If
found, and the value does not begin with a slash, and the terminal
type name is the same as the environment string I<TERM>, the
I<TERMCAP> string is used instead of reading a termcap file. If
it does begin with a slash, the string is used as a path name of
the termcap file to search. If I<TERMCAP> does not begin with a
slash and name is different from I<TERM>, B<Tgetent> searches the
files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
in that order, unless the environment variable I<TERMPATH> exists,
in which case it specifies a list of file pathnames (separated by
spaces or colons) to be searched B<instead>. Whenever multiple
files are searched and a tc field occurs in the requested entry,
the entry it names must be found in the same file or one of the
succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
environment variable string it will continue the search in the
files as above.
The extracted termcap entry is available in the object
as C<$self-E<gt>{TERMCAP}>.
It takes a hash reference as an argument with two optional keys:
=over 2
=item OSPEED
The terminal output bit rate (often mistakenly called the baud rate)
for this terminal - if not set a warning will be generated
and it will be defaulted to 9600. I<OSPEED> can be specified as
either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or
an old DSD-style speed ( where 13 equals 9600).
=item TERM
The terminal type whose termcap entry will be used - if not supplied it will
default to $ENV{TERM}: if that is not set then B<Tgetent> will croak.
=back
It calls C<croak> on failure.
=cut
sub Tgetent
{ ## public -- static method
my $class = shift;
my ($self) = @_;
$self = {} unless defined $self;
bless $self, $class;
my ( $term, $cap, $search, $field, $max, $tmp_term, $TERMCAP );
local ( $termpat, $state, $first, $entry ); # used inside eval
local $_;
# Compute PADDING factor from OSPEED (to be used by Tpad)
if ( !$self->{OSPEED} )
{
if ($^W)
{
carp "OSPEED was not set, defaulting to 9600";
}
$self->{OSPEED} = 9600;
}
if ( $self->{OSPEED} < 16 )
{
# delays for old style speeds
my @pad = (
0, 200, 133.3, 90.9, 74.3, 66.7, 50, 33.3,
16.7, 8.3, 5.5, 4.1, 2, 1, .5, .2
);
$self->{PADDING} = $pad[ $self->{OSPEED} ];
}
else
{
$self->{PADDING} = 10000 / $self->{OSPEED};
}
unless ( $self->{TERM} )
{
if ( $ENV{TERM} )
{
$self->{TERM} = $ENV{TERM} ;
}
else
{
if ( $^O eq 'MSWin32' )
{
$self->{TERM} = 'dumb';
}
else
{
croak "TERM not set";
}
}
}
$term = $self->{TERM}; # $term is the term type we are looking for
# $tmp_term is always the next term (possibly :tc=...:) we are looking for
$tmp_term = $self->{TERM};
# protect any pattern metacharacters in $tmp_term
$termpat = $tmp_term;
$termpat =~ s/(\W)/\\$1/g;
my $foo = ( exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '' );
# $entry is the extracted termcap entry
if ( ( $foo !~ m:^/:s ) && ( $foo =~ m/(^|\|)${termpat}[:|]/s ) )
{
$entry = $foo;
}
my @termcap_path = termcap_path();
if ( !@termcap_path && !$entry )
{
# last resort--fake up a termcap from terminfo
local $ENV{TERM} = $term;
if ( $^O eq 'VMS' )
{
$entry = $VMS_TERMCAP;
}
else
{
if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} )
{
eval {
my $tmp = `infocmp -C 2>/dev/null`;
$tmp =~ s/^#.*\n//gm; # remove comments
if ( ( $tmp !~ m%^/%s )
&& ( $tmp =~ /(^|\|)${termpat}[:|]/s ) )
{
$entry = $tmp;
}
};
warn "Can't run infocmp to get a termcap entry: $@" if $@;
}
else
{
# this is getting desperate now
if ( $self->{TERM} eq 'dumb' )
{
$entry = 'dumb|80-column dumb tty::am::co#80::bl=^G:cr=^M:do=^J:sf=^J:';
}
}
}
}
croak "Can't find a valid termcap file" unless @termcap_path || $entry;
$state = 1; # 0 == finished
# 1 == next file
# 2 == search again
$first = 0; # first entry (keeps term name)
$max = 32; # max :tc=...:'s
if ($entry)
{
# ok, we're starting with $TERMCAP
$first++; # we're the first entry
# do we need to continue?
if ( $entry =~ s/:tc=([^:]+):/:/ )
{
$tmp_term = $1;
# protect any pattern metacharacters in $tmp_term
$termpat = $tmp_term;
$termpat =~ s/(\W)/\\$1/g;
}
else
{
$state = 0; # we're already finished
}
}
# This is eval'ed inside the while loop for each file
$search = q{
while (<TERMCAP>) {
next if /^\\t/ || /^#/;
if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
chomp;
s/^[^:]*:// if $first++;
$state = 0;
while ($_ =~ s/\\\\$//) {
defined(my $x = <TERMCAP>) or last;
$_ .= $x; chomp;
}
last;
}
}
defined $entry or $entry = '';
$entry .= $_ if $_;
};
while ( $state != 0 )
{
if ( $state == 1 )
{
# get the next TERMCAP
$TERMCAP = shift @termcap_path
|| croak "failed termcap lookup on $tmp_term";
}
else
{
# do the same file again
# prevent endless recursion
$max-- || croak "failed termcap loop at $tmp_term";
$state = 1; # ok, maybe do a new file next time
}
open( TERMCAP, "< $TERMCAP\0" ) || croak "open $TERMCAP: $!";
eval $search;
die $@ if $@;
close TERMCAP;
# If :tc=...: found then search this file again
$entry =~ s/:tc=([^:]+):/:/ && ( $tmp_term = $1, $state = 2 );
# protect any pattern metacharacters in $tmp_term
$termpat = $tmp_term;
$termpat =~ s/(\W)/\\$1/g;
}
croak "Can't find $term" if $entry eq '';
$entry =~ s/:+\s*:+/:/g; # cleanup $entry
$entry =~ s/:+/:/g; # cleanup $entry
$self->{TERMCAP} = $entry; # save it
# print STDERR "DEBUG: $entry = ", $entry, "\n";
# Precompile $entry into the object
$entry =~ s/^[^:]*://;
foreach $field ( split( /:[\s:\\]*/, $entry ) )
{
if ( defined $field && $field =~ /^(\w{2,})$/ )
{
$self->{ '_' . $field } = 1 unless defined $self->{ '_' . $1 };
# print STDERR "DEBUG: flag $1\n";
}
elsif ( defined $field && $field =~ /^(\w{2,})\@/ )
{
$self->{ '_' . $1 } = "";
# print STDERR "DEBUG: unset $1\n";
}
elsif ( defined $field && $field =~ /^(\w{2,})#(.*)/ )
{
$self->{ '_' . $1 } = $2 unless defined $self->{ '_' . $1 };
# print STDERR "DEBUG: numeric $1 = $2\n";
}
elsif ( defined $field && $field =~ /^(\w{2,})=(.*)/ )
{
# print STDERR "DEBUG: string $1 = $2\n";
next if defined $self->{ '_' . ( $cap = $1 ) };
$_ = $2;
if ( ord('A') == 193 )
{
s/\\E/\047/g;
s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
s/\\n/\n/g;
s/\\r/\r/g;
s/\\t/\t/g;
s/\\b/\b/g;
s/\\f/\f/g;
s/\\\^/\337/g;
s/\^\?/\007/g;
s/\^(.)/pack('c',ord($1) & 31)/eg;
s/\\(.)/$1/g;
s/\337/^/g;
}
else
{
s/\\E/\033/g;
s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
s/\\n/\n/g;
s/\\r/\r/g;
s/\\t/\t/g;
s/\\b/\b/g;
s/\\f/\f/g;
s/\\\^/\377/g;
s/\^\?/\177/g;
s/\^(.)/pack('c',ord($1) & 31)/eg;
s/\\(.)/$1/g;
s/\377/^/g;
}
$self->{ '_' . $cap } = $_;
}
# else { carp "junk in $term ignored: $field"; }
}
$self->{'_pc'} = "\0" unless defined $self->{'_pc'};
$self->{'_bc'} = "\b" unless defined $self->{'_bc'};
$self;
}
# $terminal->Tpad($string, $cnt, $FH);
=item B<Tpad>
Outputs a literal string with appropriate padding for the current terminal.
It takes three arguments:
=over 2
=item B<$string>
The literal string to be output. If it starts with a number and an optional
'*' then the padding will be increased by an amount relative to this number,
if the '*' is present then this amount will be multiplied by $cnt. This part
of $string is removed before output/
=item B<$cnt>
Will be used to modify the padding applied to string as described above.
=item B<$FH>
An optional filehandle (or IO::Handle ) that output will be printed to.
=back
The padded $string is returned.
=cut
sub Tpad
{ ## public
my $self = shift;
my ( $string, $cnt, $FH ) = @_;
my ( $decr, $ms );
if ( defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/ )
{
$ms = $1;
$ms *= $cnt if $2;
$string = $3;
$decr = $self->{PADDING};
if ( $decr > .1 )
{
$ms += $decr / 2;
$string .= $self->{'_pc'} x ( $ms / $decr );
}
}
print $FH $string if $FH;
$string;
}
# $terminal->Tputs($cap, $cnt, $FH);
=item B<Tputs>
Output the string for the given capability padded as appropriate without
any parameter substitution.
It takes three arguments:
=over 2
=item B<$cap>
The capability whose string is to be output.
=item B<$cnt>
A count passed to Tpad to modify the padding applied to the output string.
If $cnt is zero or one then the resulting string will be cached.
=item B<$FH>
An optional filehandle (or IO::Handle ) that output will be printed to.
=back
The appropriate string for the capability will be returned.
=cut
sub Tputs
{ ## public
my $self = shift;
my ( $cap, $cnt, $FH ) = @_;
my $string;
$cnt = 0 unless $cnt;
if ( $cnt > 1 )
{
$string = Tpad( $self, $self->{ '_' . $cap }, $cnt );
}
else
{
# cache result because Tpad can be slow
unless ( exists $self->{$cap} )
{
$self->{$cap} =
exists $self->{"_$cap"}
? Tpad( $self, $self->{"_$cap"}, 1 )
: undef;
}
$string = $self->{$cap};
}
print $FH $string if $FH;
$string;
}
# $terminal->Tgoto($cap, $col, $row, $FH);
=item B<Tgoto>
B<Tgoto> decodes a cursor addressing string with the given parameters.
There are four arguments:
=over 2
=item B<$cap>
The name of the capability to be output.
=item B<$col>
The first value to be substituted in the output string ( usually the column
in a cursor addressing capability )
=item B<$row>
The second value to be substituted in the output string (usually the row
in cursor addressing capabilities)
=item B<$FH>
An optional filehandle (or IO::Handle ) to which the output string will be
printed.
=back
Substitutions are made with $col and $row in the output string with the
following sprintf() line formats:
%% output `%'
%d output value as in printf %d
%2 output value as in printf %2d
%3 output value as in printf %3d
%. output value as in printf %c
%+x add x to value, then do %.
%>xy if value > x then add y, no output
%r reverse order of two parameters, no output
%i increment by one, no output
%B BCD (16*(value/10)) + (value%10), no output
%n exclusive-or all parameters with 0140 (Datamedia 2500)
%D Reverse coding (value - 2*(value%16)), no output (Delta Data)
The output string will be returned.
=cut
sub Tgoto
{ ## public
my $self = shift;
my ( $cap, $code, $tmp, $FH ) = @_;
my $string = $self->{ '_' . $cap };
my $result = '';
my $after = '';
my $online = 0;
my @tmp = ( $tmp, $code );
my $cnt = $code;
while ( $string =~ /^([^%]*)%(.)(.*)/ )
{
$result .= $1;
$code = $2;
$string = $3;
if ( $code eq 'd' )
{
$result .= sprintf( "%d", shift(@tmp) );
}
elsif ( $code eq '.' )
{
$tmp = shift(@tmp);
if ( $tmp == 0 || $tmp == 4 || $tmp == 10 )
{
if ($online)
{
++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
}
else
{
++$tmp, $after .= $self->{'_bc'};
}
}
$result .= sprintf( "%c", $tmp );
$online = !$online;
}
elsif ( $code eq '+' )
{
$result .= sprintf( "%c", shift(@tmp) + ord($string) );
$string = substr( $string, 1, 99 );
$online = !$online;
}
elsif ( $code eq 'r' )
{
( $code, $tmp ) = @tmp;
@tmp = ( $tmp, $code );
$online = !$online;
}
elsif ( $code eq '>' )
{
( $code, $tmp, $string ) = unpack( "CCa99", $string );
if ( $tmp[0] > $code )
{
$tmp[0] += $tmp;
}
}
elsif ( $code eq '2' )
{
$result .= sprintf( "%02d", shift(@tmp) );
$online = !$online;
}
elsif ( $code eq '3' )
{
$result .= sprintf( "%03d", shift(@tmp) );
$online = !$online;
}
elsif ( $code eq 'i' )
{
( $code, $tmp ) = @tmp;
@tmp = ( $code + 1, $tmp + 1 );
}
else
{
return "OOPS";
}
}
$string = Tpad( $self, $result . $string . $after, $cnt );
print $FH $string if $FH;
$string;
}
# $terminal->Trequire(qw/ce ku kd/);
=item B<Trequire>
Takes a list of capabilities as an argument and will croak if one is not
found.
=cut
sub Trequire
{ ## public
my $self = shift;
my ( $cap, @undefined );
foreach $cap (@_)
{
push( @undefined, $cap )
unless defined $self->{ '_' . $cap } && $self->{ '_' . $cap };
}
croak "Terminal does not support: (@undefined)" if @undefined;
}
=back
=head1 EXAMPLES
use Term::Cap;
# Get terminal output speed
require POSIX;
my $termios = POSIX::Termios->new;
$termios->getattr;
my $ospeed = $termios->getospeed;
# Old-style ioctl code to get ospeed:
# require 'ioctl.pl';
# ioctl(TTY,$TIOCGETP,$sgtty);
# ($ispeed,$ospeed) = unpack('cc',$sgtty);
# allocate and initialize a terminal structure
my $terminal = Term::Cap->Tgetent({ TERM => undef, OSPEED => $ospeed });
# require certain capabilities to be available
$terminal->Trequire(qw/ce ku kd/);
# Output Routines, if $FH is undefined these just return the string
# Tgoto does the % expansion stuff with the given args
$terminal->Tgoto('cm', $col, $row, $FH);
# Tputs doesn't do any % expansion.
$terminal->Tputs('dl', $count = 1, $FH);
=head1 COPYRIGHT AND LICENSE
Copyright 1995-2015 (c) perl5 porters.
This software is free software and can be modified and distributed under
the same terms as Perl itself.
Please see the file README in the Perl source distribution for details of
the Perl license.
=head1 AUTHOR
This module is part of the core Perl distribution and is also maintained
for CPAN by Jonathan Stowe <jns@gellyfish.co.uk>.
The code is hosted on Github: https://github.com/jonathanstowe/Term-Cap
please feel free to fork, submit patches etc, etc there.
=head1 SEE ALSO
termcap(5)
=cut
# Below is a default entry for systems where there are terminals but no
# termcap
1;
__DATA__
vt220|vt200|DEC VT220 in vt100 emulation mode:
am:mi:xn:xo:
co#80:li#24:
RA=\E[?7l:SA=\E[?7h:
ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0:
bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH:
cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B:
ei=\E[4l:ho=\E[H:im=\E[4h:
is=\E[1;24r\E[24;1H:
nd=\E[C:
kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H:
mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m:
kb=\0177:
r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8:
sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I:
ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l:

188
Agent-Windows/OGP64/usr/share/perl5/5.40/Term/Complete.pm Normal file
View file

@ -0,0 +1,188 @@
package Term::Complete;
require 5.000;
require Exporter;
use strict;
our @ISA = qw(Exporter);
our @EXPORT = qw(Complete);
our $VERSION = '1.403';
# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91
=head1 NAME
Term::Complete - Perl word completion module
=head1 SYNOPSIS
$input = Complete('prompt_string', \@completion_list);
$input = Complete('prompt_string', @completion_list);
=head1 DESCRIPTION
This routine provides word completion on the list of words in
the array (or array ref).
The tty driver is put into raw mode and restored using an operating
system specific command, in UNIX-like environments C<stty>.
The following command characters are defined:
=over 4
=item E<lt>tabE<gt>
Attempts word completion.
Cannot be changed.
=item ^D
Prints completion list.
Defined by I<$Term::Complete::complete>.
=item ^U
Erases the current input.
Defined by I<$Term::Complete::kill>.
=item E<lt>delE<gt>, E<lt>bsE<gt>
Erases one character.
Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>.
=back
=head1 DIAGNOSTICS
Bell sounds when word completion fails.
=head1 BUGS
The completion character E<lt>tabE<gt> cannot be changed.
=head1 AUTHOR
Wayne Thompson
=cut
our($complete, $kill, $erase1, $erase2, $tty_raw_noecho, $tty_restore, $stty, $tty_safe_restore);
our($tty_saved_state) = '';
CONFIG: {
$complete = "\004";
$kill = "\025";
$erase1 = "\177";
$erase2 = "\010";
foreach my $s (qw(/bin/stty /usr/bin/stty)) {
if (-x $s) {
$tty_raw_noecho = "$s raw -echo";
$tty_restore = "$s -raw echo";
$tty_safe_restore = $tty_restore;
$stty = $s;
last;
}
}
}
sub Complete {
my($prompt, @cmp_lst, $cmp, $test, $l, @match);
my ($return, $r) = ("", 0);
$return = "";
$r = 0;
$prompt = shift;
if (ref $_[0] || $_[0] =~ /^\*/) {
@cmp_lst = sort @{$_[0]};
}
else {
@cmp_lst = sort(@_);
}
# Attempt to save the current stty state, to be restored later
if (defined $stty && defined $tty_saved_state && $tty_saved_state eq '') {
$tty_saved_state = qx($stty -g 2>/dev/null);
if ($?) {
# stty -g not supported
$tty_saved_state = undef;
}
else {
$tty_saved_state =~ s/\s+$//g;
$tty_restore = qq($stty "$tty_saved_state" 2>/dev/null);
}
}
system $tty_raw_noecho if defined $tty_raw_noecho;
LOOP: {
local $_;
print($prompt, $return);
while (($_ = getc(STDIN)) ne "\r") {
CASE: {
# (TAB) attempt completion
$_ eq "\t" && do {
@match = grep(/^\Q$return/, @cmp_lst);
unless ($#match < 0) {
$l = length($test = shift(@match));
foreach $cmp (@match) {
until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
$l--;
}
}
print("\a");
print($test = substr($test, $r, $l - $r));
$r = length($return .= $test);
}
last CASE;
};
# (^D) completion list
$_ eq $complete && do {
print(join("\r\n", '', grep(/^\Q$return/, @cmp_lst)), "\r\n");
redo LOOP;
};
# (^U) kill
$_ eq $kill && do {
if ($r) {
$r = 0;
$return = "";
print("\r\n");
redo LOOP;
}
last CASE;
};
# (DEL) || (BS) erase
($_ eq $erase1 || $_ eq $erase2) && do {
if($r) {
print("\b \b");
chop($return);
$r--;
}
last CASE;
};
# printable char
ord >= ord(" ") && do {
$return .= $_;
$r++;
print;
last CASE;
};
}
}
}
# system $tty_restore if defined $tty_restore;
if (defined $tty_saved_state && defined $tty_restore && defined $tty_safe_restore)
{
system $tty_restore;
if ($?) {
# tty_restore caused error
system $tty_safe_restore;
}
}
print("\n");
$return;
}
1;

487
Agent-Windows/OGP64/usr/share/perl5/5.40/Term/ReadLine.pm Normal file
View file

@ -0,0 +1,487 @@
=head1 NAME
Term::ReadLine - Perl interface to various C<readline> packages.
If no real package is found, substitutes stubs instead of basic functions.
=head1 SYNOPSIS
use Term::ReadLine;
my $term = Term::ReadLine->new('Simple Perl calc');
my $prompt = "Enter your arithmetic expression: ";
my $OUT = $term->OUT || \*STDOUT;
while ( defined ($_ = $term->readline($prompt)) ) {
my $res = eval($_);
warn $@ if $@;
print $OUT $res, "\n" unless $@;
$term->addhistory($_) if /\S/;
}
=head1 DESCRIPTION
This package is just a front end to some other packages. It's a stub to
set up a common interface to the various ReadLine implementations found on
CPAN (under the C<Term::ReadLine::*> namespace).
=head1 Minimal set of supported functions
All the supported functions should be called as methods, i.e., either as
$term = Term::ReadLine->new('name');
or as
$term->addhistory('row');
where $term is a return value of Term::ReadLine-E<gt>new().
=over 12
=item C<ReadLine>
returns the actual package that executes the commands. Among possible
values are C<Term::ReadLine::Gnu>, C<Term::ReadLine::Perl>,
C<Term::ReadLine::Stub>.
=item C<new>
returns the handle for subsequent calls to following
functions. Argument is the name of the application. Optionally can be
followed by two arguments for C<IN> and C<OUT> filehandles. These
arguments should be globs.
=item C<readline>
gets an input line, I<possibly> with actual C<readline>
support. Trailing newline is removed. Returns C<undef> on C<EOF>.
=item C<addhistory>
adds the line to the history of input, from where it can be used if
the actual C<readline> is present.
=item C<IN>, C<OUT>
return the filehandles for input and output or C<undef> if C<readline>
input and output cannot be used for Perl.
=item C<MinLine>
If argument is specified, it is an advice on minimal size of line to
be included into history. C<undef> means do not include anything into
history. Returns the old value.
=item C<findConsole>
returns an array with two strings that give most appropriate names for
files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
The strings returned may not be useful for 3-argument open().
=item Attribs
returns a reference to a hash which describes internal configuration
of the package. Names of keys in this hash conform to standard
conventions with the leading C<rl_> stripped.
=item C<Features>
Returns a reference to a hash with keys being features present in
current implementation. Several optional features are used in the
minimal interface: C<appname> should be present if the first argument
to C<new> is recognized, and C<minline> should be present if
C<MinLine> method is not dummy. C<autohistory> should be present if
lines are put into history automatically (maybe subject to
C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy.
If C<Features> method reports a feature C<attribs> as present, the
method C<Attribs> is not dummy.
=back
=head1 Additional supported functions
Actually C<Term::ReadLine> can use some other package, that will
support a richer set of commands.
All these commands are callable via method interface and have names
which conform to standard conventions with the leading C<rl_> stripped.
The stub package included with the perl distribution allows some
additional methods:
=over 12
=item C<tkRunning>
makes Tk event loop run when waiting for user input (i.e., during
C<readline> method).
=item C<event_loop>
Registers call-backs to wait for user input (i.e., during C<readline>
method). This supersedes tkRunning.
The first call-back registered is the call back for waiting. It is
expected that the callback will call the current event loop until
there is something waiting to get on the input filehandle. The parameter
passed in is the return value of the second call back.
The second call-back registered is the call back for registration. The
input filehandle (often STDIN, but not necessarily) will be passed in.
For example, with AnyEvent:
$term->event_loop(sub {
my $data = shift;
$data->[1] = AE::cv();
$data->[1]->recv();
}, sub {
my $fh = shift;
my $data = [];
$data->[0] = AE::io($fh, 0, sub { $data->[1]->send() });
$data;
});
The second call-back is optional if the call back is registered prior to
the call to $term-E<gt>readline.
Deregistration is done in this case by calling event_loop with C<undef>
as its parameter:
$term->event_loop(undef);
This will cause the data array ref to be removed, allowing normal garbage
collection to clean it up. With AnyEvent, that will cause $data->[0] to
be cleaned up, and AnyEvent will automatically cancel the watcher at that
time. If another loop requires more than that to clean up a file watcher,
that will be up to the caller to handle.
=item C<ornaments>
makes the command line stand out by using termcap data. The argument
to C<ornaments> should be 0, 1, or a string of a form
C<"aa,bb,cc,dd">. Four components of this string should be names of
I<terminal capacities>, first two will be issued to make the prompt
standout, last two to make the input line standout.
=item C<newTTY>
takes two arguments which are input filehandle and output filehandle.
Switches to use these filehandles.
=back
One can check whether the currently loaded ReadLine package supports
these methods by checking for corresponding C<Features>.
=head1 EXPORTS
None
=head1 ENVIRONMENT
The environment variable C<PERL_RL> governs which ReadLine clone is
loaded. If the value is false, a dummy interface is used. If the value
is true, it should be tail of the name of the package to use, such as
C<Perl> or C<Gnu>.
As a special case, if the value of this variable is space-separated,
the tail might be used to disable the ornaments by setting the tail to
be C<o=0> or C<ornaments=0>. The head should be as described above, say
If the variable is not set, or if the head of space-separated list is
empty, the best available package is loaded.
export "PERL_RL=Perl o=0" # Use Perl ReadLine sans ornaments
export "PERL_RL= o=0" # Use best available ReadLine sans ornaments
(Note that processing of C<PERL_RL> for ornaments is in the discretion of the
particular used C<Term::ReadLine::*> package).
=cut
use strict;
package Term::ReadLine::Stub;
our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
$DB::emacs = $DB::emacs; # To pacify -w
our @rl_term_set;
*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
sub PERL_UNICODE_STDIN () { 0x0001 }
sub ReadLine {'Term::ReadLine::Stub'}
sub readline {
my $self = shift;
my ($in,$out,$str) = @$self;
my $prompt = shift;
print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2];
$self->register_Tk
if not $Term::ReadLine::registered and $Term::ReadLine::toloop;
#$str = scalar <$in>;
$str = $self->get_line;
utf8::upgrade($str)
if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
utf8::valid($str);
print $out $rl_term_set[3];
# bug in 5.000: chomping empty string creates length -1:
chomp $str if defined $str;
$str;
}
sub addhistory {}
# used for testing purpose
sub devtty { return '/dev/tty' }
sub findConsole {
my $console;
my $consoleOUT;
my $devtty = devtty();
if ($^O ne 'MSWin32' and -e $devtty) {
$console = $devtty;
} elsif ($^O eq 'MSWin32' or $^O eq 'msys' or -e "con") {
$console = 'CONIN$';
$consoleOUT = 'CONOUT$';
} elsif ($^O eq 'VMS') {
$console = "sys\$command";
} elsif ($^O eq 'os2' && !$DB::emacs) {
$console = "/dev/con";
} else {
$console = undef;
}
$consoleOUT = $console unless defined $consoleOUT;
$console = "&STDIN" unless defined $console;
if ($console eq $devtty && !open(my $fh, "<", $console)) {
$console = "&STDIN";
undef($consoleOUT);
}
if (!defined $consoleOUT) {
$consoleOUT = defined fileno(STDERR) && $^O ne 'MSWin32' ? "&STDERR" : "&STDOUT";
}
($console,$consoleOUT);
}
sub new {
die "method new called with wrong number of arguments"
unless @_==2 or @_==4;
#local (*FIN, *FOUT);
my ($FIN, $FOUT, $ret);
if (@_==2) {
my($console, $consoleOUT) = $_[0]->findConsole;
# the Windows CONIN$ needs GENERIC_WRITE mode to allow
# a SetConsoleMode() if we end up using Term::ReadKey
open FIN, (( $^O eq 'MSWin32' && $console eq 'CONIN$' ) ? '+<' : '<' ), $console;
# RT #132008: Still need 2-arg open here
open FOUT,">$consoleOUT";
#OUT->autoflush(1); # Conflicts with debugger?
my $sel = select(FOUT);
$| = 1; # for DB::OUT
select($sel);
$ret = bless [\*FIN, \*FOUT];
} else { # Filehandles supplied
$FIN = $_[2]; $FOUT = $_[3];
#OUT->autoflush(1); # Conflicts with debugger?
my $sel = select($FOUT);
$| = 1; # for DB::OUT
select($sel);
$ret = bless [$FIN, $FOUT];
}
if ($ret->Features->{ornaments}
and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
local $Term::ReadLine::termcap_nowarn = 1;
$ret->ornaments(1);
}
return $ret;
}
sub newTTY {
my ($self, $in, $out) = @_;
$self->[0] = $in;
$self->[1] = $out;
my $sel = select($out);
$| = 1; # for DB::OUT
select($sel);
}
sub IN { shift->[0] }
sub OUT { shift->[1] }
sub MinLine { undef }
sub Attribs { {} }
my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
sub Features { \%features }
#sub get_line {
# my $self = shift;
# my $in = $self->IN;
# local ($/) = "\n";
# return scalar <$in>;
#}
package Term::ReadLine; # So late to allow the above code be defined?
our $VERSION = '1.17';
my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
if ($which) {
if ($which =~ /\bgnu\b/i){
eval "use Term::ReadLine::Gnu;";
} elsif ($which =~ /\bperl\b/i) {
eval "use Term::ReadLine::Perl;";
} elsif ($which =~ /^(Stub|TermCap|Tk)$/) {
# it is already in memory to avoid false exception as seen in:
# PERL_RL=Stub perl -e'$SIG{__DIE__} = sub { print @_ }; require Term::ReadLine'
} else {
eval "use Term::ReadLine::$which;";
}
} elsif (defined $which and $which ne '') { # Defined but false
# Do nothing fancy
} else {
eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::EditLine; 1" or eval "use Term::ReadLine::Perl; 1";
}
#require FileHandle;
# To make possible switch off RL in debugger: (Not needed, work done
# in debugger).
our @ISA;
if (defined &Term::ReadLine::Gnu::readline) {
@ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
} elsif (defined &Term::ReadLine::EditLine::readline) {
@ISA = qw(Term::ReadLine::EditLine Term::ReadLine::Stub);
} elsif (defined &Term::ReadLine::Perl::readline) {
@ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
} elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
@ISA = "Term::ReadLine::$which";
} else {
@ISA = qw(Term::ReadLine::Stub);
}
package Term::ReadLine::TermCap;
# Prompt-start, prompt-end, command-line-start, command-line-end
# -- zero-width beautifies to emit around prompt and the command line.
our @rl_term_set = ("","","","");
# string encoded:
our $rl_term_set = ',,,';
our $terminal;
sub LoadTermCap {
return if defined $terminal;
require Term::Cap;
$terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
}
sub ornaments {
shift;
return $rl_term_set unless @_;
$rl_term_set = shift;
$rl_term_set ||= ',,,';
$rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
my @ts = split /,/, $rl_term_set, 4;
eval { LoadTermCap };
unless (defined $terminal) {
warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
$rl_term_set = ',,,';
return;
}
@rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
return $rl_term_set;
}
package Term::ReadLine::Tk;
# This package inserts a Tk->fileevent() before the diamond operator.
# The Tk watcher dispatches Tk events until the filehandle returned by
# the$term->IN() accessor becomes ready for reading. It's assumed
# that the diamond operator will return a line of input immediately at
# that point.
my ($giveup);
# maybe in the future the Tk-specific aspects will be removed.
sub Tk_loop{
if (ref $Term::ReadLine::toloop)
{
$Term::ReadLine::toloop->[0]->($Term::ReadLine::toloop->[2]);
}
else
{
Tk::DoOneEvent(0) until $giveup;
$giveup = 0;
}
};
sub register_Tk {
my $self = shift;
unless ($Term::ReadLine::registered++)
{
if (ref $Term::ReadLine::toloop)
{
$Term::ReadLine::toloop->[2] = $Term::ReadLine::toloop->[1]->($self->IN) if $Term::ReadLine::toloop->[1];
}
else
{
Tk->fileevent($self->IN,'readable',sub { $giveup = 1});
}
}
};
sub tkRunning {
$Term::ReadLine::toloop = $_[1] if @_ > 1;
$Term::ReadLine::toloop;
}
sub event_loop {
shift;
# T::RL::Gnu and T::RL::Perl check that this exists, if not,
# it doesn't call the loop. Those modules will need to be
# fixed before this can be removed.
if (not defined &Tk::DoOneEvent)
{
*Tk::DoOneEvent = sub {
die "what?"; # this shouldn't be called.
}
}
# store the callback in toloop, again so that other modules will
# recognise it and call us for the loop.
$Term::ReadLine::toloop = [ @_ ] if @_ > 0; # 0 because we shifted off $self.
$Term::ReadLine::toloop;
}
sub PERL_UNICODE_STDIN () { 0x0001 }
sub get_line {
my $self = shift;
my ($in,$out,$str) = @$self;
if ($Term::ReadLine::toloop) {
$self->register_Tk if not $Term::ReadLine::registered;
$self->Tk_loop;
}
local ($/) = "\n";
$str = <$in>;
utf8::upgrade($str)
if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
utf8::valid($str);
print $out $rl_term_set[3];
# bug in 5.000: chomping empty string creates length -1:
chomp $str if defined $str;
$str;
}
1;

452
Agent-Windows/OGP64/usr/share/perl5/5.40/Term/Table.pm Normal file
View file

@ -0,0 +1,452 @@
package Term::Table;
use strict;
use warnings;
our $VERSION = '0.018';
use Term::Table::Cell();
use Term::Table::Util qw/term_size uni_length USE_GCS/;
use Scalar::Util qw/blessed/;
use List::Util qw/max sum/;
use Carp qw/croak carp/;
use Term::Table::HashBase qw/rows _columns collapse max_width mark_tail sanitize show_header auto_columns no_collapse header allow_overflow pad/;
sub BORDER_SIZE() { 4 } # '| ' and ' |' borders
sub DIV_SIZE() { 3 } # ' | ' column delimiter
sub CELL_PAD_SIZE() { 2 } # space on either side of the |
sub init {
my $self = shift;
croak "You cannot have a table with no rows"
unless $self->{+ROWS} && @{$self->{+ROWS}};
$self->{+MAX_WIDTH} ||= term_size();
$self->{+NO_COLLAPSE} ||= {};
if (ref($self->{+NO_COLLAPSE}) eq 'ARRAY') {
$self->{+NO_COLLAPSE} = {map { ($_ => 1) } @{$self->{+NO_COLLAPSE}}};
}
if ($self->{+NO_COLLAPSE} && $self->{+HEADER}) {
my $header = $self->{+HEADER};
for(my $idx = 0; $idx < @$header; $idx++) {
$self->{+NO_COLLAPSE}->{$idx} ||= $self->{+NO_COLLAPSE}->{$header->[$idx]};
}
}
$self->{+PAD} = 4 unless defined $self->{+PAD};
$self->{+COLLAPSE} = 1 unless defined $self->{+COLLAPSE};
$self->{+SANITIZE} = 1 unless defined $self->{+SANITIZE};
$self->{+MARK_TAIL} = 1 unless defined $self->{+MARK_TAIL};
if($self->{+HEADER}) {
$self->{+SHOW_HEADER} = 1 unless defined $self->{+SHOW_HEADER};
}
else {
$self->{+HEADER} = [];
$self->{+AUTO_COLUMNS} = 1;
$self->{+SHOW_HEADER} = 0;
}
}
sub columns {
my $self = shift;
$self->regen_columns unless $self->{+_COLUMNS};
return $self->{+_COLUMNS};
}
sub regen_columns {
my $self = shift;
my $has_header = $self->{+SHOW_HEADER} && @{$self->{+HEADER}};
my %new_col = (width => 0, count => $has_header ? -1 : 0);
my $cols = [map { {%new_col} } @{$self->{+HEADER}}];
my @rows = @{$self->{+ROWS}};
for my $row ($has_header ? ($self->{+HEADER}, @rows) : (@rows)) {
for my $ci (0 .. max(@$cols - 1, @$row - 1)) {
$cols->[$ci] ||= {%new_col} if $self->{+AUTO_COLUMNS};
my $c = $cols->[$ci] or next;
$c->{idx} ||= $ci;
$c->{rows} ||= [];
my $r = $row->[$ci];
$r = Term::Table::Cell->new(value => $r)
unless blessed($r)
&& ($r->isa('Term::Table::Cell')
|| $r->isa('Term::Table::CellStack')
|| $r->isa('Term::Table::Spacer'));
$r->sanitize if $self->{+SANITIZE};
$r->mark_tail if $self->{+MARK_TAIL};
my $rs = $r->width;
$c->{width} = $rs if $rs > $c->{width};
$c->{count}++ if $rs;
push @{$c->{rows}} => $r;
}
}
# Remove any empty columns we can
@$cols = grep {$_->{count} > 0 || $self->{+NO_COLLAPSE}->{$_->{idx}}} @$cols
if $self->{+COLLAPSE};
my $current = sum(map {$_->{width}} @$cols);
my $border = sum(BORDER_SIZE, $self->{+PAD}, DIV_SIZE * (@$cols - 1));
my $total = $current + $border;
if ($total > $self->{+MAX_WIDTH}) {
my $fair = ($self->{+MAX_WIDTH} - $border) / @$cols;
if ($fair < 1) {
return $self->{+_COLUMNS} = $cols if $self->{+ALLOW_OVERFLOW};
croak "Table is too large ($total including $self->{+PAD} padding) to fit into max-width ($self->{+MAX_WIDTH})";
}
my $under = 0;
my @fix;
for my $c (@$cols) {
if ($c->{width} > $fair) {
push @fix => $c;
}
else {
$under += $c->{width};
}
}
# Recalculate fairness
$fair = int(($self->{+MAX_WIDTH} - $border - $under) / @fix);
if ($fair < 1) {
return $self->{+_COLUMNS} = $cols if $self->{+ALLOW_OVERFLOW};
croak "Table is too large ($total including $self->{+PAD} padding) to fit into max-width ($self->{+MAX_WIDTH})";
}
# Adjust over-long columns
$_->{width} = $fair for @fix;
}
$self->{+_COLUMNS} = $cols;
}
sub render {
my $self = shift;
my $cols = $self->columns;
for my $col (@$cols) {
for my $cell (@{$col->{rows}}) {
$cell->reset;
}
}
my $width = sum(BORDER_SIZE, $self->{+PAD}, DIV_SIZE * @$cols, map { $_->{width} } @$cols);
#<<< NO-TIDY
my $border = '+' . join('+', map { '-' x ($_->{width} + CELL_PAD_SIZE) } @$cols) . '+';
my $template = '|' . join('|', map { my $w = $_->{width} + CELL_PAD_SIZE; '%s' } @$cols) . '|';
my $spacer = '|' . join('|', map { ' ' x ($_->{width} + CELL_PAD_SIZE) } @$cols) . '|';
#>>>
my @out = ($border);
my ($row, $split, $found) = (0, 0, 0);
while(1) {
my @row;
my $is_spacer = 0;
for my $col (@$cols) {
my $r = $col->{rows}->[$row];
unless($r) {
push @row => '';
next;
}
my ($v, $vw);
if ($r->isa('Term::Table::Cell')) {
my $lw = $r->border_left_width;
my $rw = $r->border_right_width;
$vw = $col->{width} - $lw - $rw;
$v = $r->break->next($vw);
}
elsif ($r->isa('Term::Table::CellStack')) {
($v, $vw) = $r->break->next($col->{width});
}
elsif ($r->isa('Term::Table::Spacer')) {
$is_spacer = 1;
}
if ($is_spacer) {
last;
}
elsif (defined $v) {
$found++;
my $bcolor = $r->border_color || '';
my $vcolor = $r->value_color || '';
my $reset = $r->reset_color || '';
if (my $need = $vw - uni_length($v)) {
$v .= ' ' x $need;
}
my $rt = "${reset}${bcolor}\%s${reset} ${vcolor}\%s${reset} ${bcolor}\%s${reset}";
push @row => sprintf($rt, $r->border_left || '', $v, $r->border_right || '');
}
else {
push @row => ' ' x ($col->{width} + 2);
}
}
if (!grep {$_ && m/\S/} @row) {
last unless $found || $is_spacer;
push @out => $border if $row == 0 && $self->{+SHOW_HEADER} && @{$self->{+HEADER}};
push @out => $spacer if $split > 1 || $is_spacer;
$row++;
$split = 0;
$found = 0;
next;
}
if ($split == 1 && @out > 1 && $out[-2] ne $border && $out[-2] ne $spacer) {
my $last = pop @out;
push @out => ($spacer, $last);
}
push @out => sprintf($template, @row);
$split++;
}
pop @out while @out && $out[-1] eq $spacer;
unless (USE_GCS) {
for my $row (@out) {
next unless $row =~ m/[^\x00-\x7F]/;
unshift @out => "Unicode::GCString is not installed, table may not display all unicode characters properly";
last;
}
}
return (@out, $border);
}
sub display {
my $self = shift;
my ($fh) = @_;
my @parts = map "$_\n", $self->render;
print $fh @parts if $fh;
print @parts;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Term::Table - Format a header and rows into a table
=head1 DESCRIPTION
This is used by some failing tests to provide diagnostics about what has gone
wrong. This module is able to format rows of data into tables.
=head1 SYNOPSIS
use Term::Table;
my $table = Term::Table->new(
max_width => 80, # Defaults to terminal size
pad => 4, # Extra padding between table and max-width (defaults to 4)
allow_overflow => 0, # Default is 0, when off an exception will be thrown if the table is too big
collapse => 1, # Do not show empty columns
header => ['name', 'age', 'hair color'],
rows => [
['Fred Flintstone', 2000000, 'black'],
['Wilma Flintstone', 1999995, 'red'],
...
],
);
say $_ for $table->render;
This prints a table like this:
+------------------+---------+------------+
| name | age | hair color |
+------------------+---------+------------+
| Fred Flintstone | 2000000 | black |
| Wilma Flintstone | 1999995 | red |
| ... | ... | ... |
+------------------+---------+------------+
=head1 INTERFACE
use Term::Table;
my $table = Term::Table->new(...);
=head2 OPTIONS
=over 4
=item header => [ ... ]
If you want a header specify it here.
This takes an arrayref with each columns heading.
=item rows => [ [...], [...], ... ]
This should be an arrayref containing an arrayref per row.
=item collapse => $bool
Use this if you want to hide empty columns, that is any column that has no data
in any row. Having a header for the column will not effect collapse.
=item max_width => $num
Set the maximum width of the table, the table may not be this big, but it will
be no bigger. If none is specified it will attempt to find the width of your
terminal and use that, otherwise it falls back to the terminal width or C<80>.
=item pad => $num
Defaults to C<4>, extra padding for row width calculations.
Default is for legacy support.
Set this to C<0> to turn padding off.
=item allow_overflow => $bool
Defaults to C<0>. If this is off then an exception will be thrown if the table
cannot be made to fit inside the max-width. If this is set to C<1> then the
table will be rendered anyway, larger than max-width, if it is not possible
to stay within the max-width. In other words this turns max-width from a
hard-limit to a soft recommendation.
=item sanitize => $bool
This will sanitize all the data in the table such that newlines, control
characters, and all whitespace except for ASCII 20 C<' '> are replaced with
escape sequences. This prevents newlines, tabs, and similar whitespace from
disrupting the table.
B<Note:> newlines are marked as C<\n>, but a newline is also inserted into the
data so that it typically displays in a way that is useful to humans.
Example:
my $field = "foo\nbar\nbaz\n";
print join "\n" => table(
sanitize => 1,
rows => [
[$field, 'col2' ],
['row2 col1', 'row2 col2']
]
);
Prints:
+-----------------+-----------+
| foo\n | col2 |
| bar\n | |
| baz\n | |
| | |
| row2 col1 | row2 col2 |
+-----------------+-----------+
So it marks the newlines by inserting the escape sequence, but it also shows
the data across as many lines as it would normally display.
=item mark_tail => $bool
This will replace the last whitespace character of any trailing whitespace with
its escape sequence. This makes it easier to notice trailing whitespace when
comparing values.
=item show_header => $bool
Set this to false to hide the header. This defaults to true if the header is
set, false if no header is provided.
=item auto_columns => $bool
Set this to true to automatically add columns that are not named in the header.
This defaults to false if a header is provided, and defaults to true when there
is no header.
=item no_collapse => [ $col_num_a, $col_num_b, ... ]
=item no_collapse => [ $col_name_a, $col_name_b, ... ]
=item no_collapse => { $col_num_a => 1, $col_num_b => 1, ... }
=item no_collapse => { $col_name_a => 1, $col_name_b => 1, ... }
Specify (by number and/or name) columns that should not be removed when empty.
The 'name' form only works when a header is specified. There is currently no
protection to insure that names you specify are actually in the header, invalid
names are ignored, patches to fix this will be happily accepted.
=back
=head1 NOTE ON UNICODE/WIDE CHARACTERS
Some unicode characters, such as C<婧> (C<U+5A67>) are wider than others. These
will render just fine if you C<use utf8;> as necessary, and
L<Unicode::GCString> is installed, however if the module is not installed there
will be anomalies in the table:
+-----+-----+---+
| a | b | c |
+-----+-----+---+
| 婧 | x | y |
| x | y | z |
| x | 婧 | z |
+-----+-----+---+
=head1 SOURCE
The source code repository for C<Term-Table> can be found at
L<https://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 L<https://dev.perl.org/licenses/>
=cut

147
Agent-Windows/OGP64/usr/share/perl5/5.40/Term/Table/Cell.pm Normal file
View file

@ -0,0 +1,147 @@
package Term::Table::Cell;
use strict;
use warnings;
our $VERSION = '0.018';
use Term::Table::LineBreak();
use Term::Table::Util qw/uni_length/;
use List::Util qw/sum/;
use Term::Table::HashBase qw/value border_left border_right _break _widths border_color value_color reset_color/;
my %CHAR_MAP = (
# Special case, \n should render as \n, but also actually do the newline thing
"\n" => "\\n\n",
"\a" => '\\a',
"\b" => '\\b',
"\e" => '\\e',
"\f" => '\\f',
"\r" => '\\r',
"\t" => '\\t',
" " => ' ',
);
sub init {
my $self = shift;
# Stringify
$self->{+VALUE} = defined $self->{+VALUE} ? "$self->{+VALUE}" : '';
}
sub char_id {
my $class = shift;
my ($char) = @_;
return "\\N{U+" . sprintf("\%X", ord($char)) . "}";
}
sub show_char {
my $class = shift;
my ($char, %props) = @_;
return $char if $props{no_newline} && $char eq "\n";
return $CHAR_MAP{$char} || $class->char_id($char);
}
sub sanitize {
my $self = shift;
$self->{+VALUE} =~ s/([\s\t\p{Zl}\p{C}\p{Zp}])/$self->show_char($1)/ge; # All whitespace except normal space
}
sub mark_tail {
my $self = shift;
$self->{+VALUE} =~ s/([\s\t\p{Zl}\p{C}\p{Zp}])$/$1 eq ' ' ? $self->char_id($1) : $self->show_char($1, no_newline => 1)/se;
}
sub value_width {
my $self = shift;
my $w = $self->{+_WIDTHS} ||= {};
return $w->{value} if defined $w->{value};
my @parts = split /(\n)/, $self->{+VALUE};
my $max = 0;
while (@parts) {
my $text = shift @parts;
my $sep = shift @parts || '';
my $len = uni_length("$text");
$max = $len if $len > $max;
}
return $w->{value} = $max;
}
sub border_left_width {
my $self = shift;
$self->{+_WIDTHS}->{left} ||= uni_length($self->{+BORDER_LEFT} || '');
}
sub border_right_width {
my $self = shift;
$self->{+_WIDTHS}->{right} ||= uni_length($self->{+BORDER_RIGHT} || '');
}
sub width {
my $self = shift;
$self->{+_WIDTHS}->{all} ||= sum(map { $self->$_ } qw/value_width border_left_width border_right_width/);
}
sub break {
my $self = shift;
$self->{+_BREAK} ||= Term::Table::LineBreak->new(string => $self->{+VALUE});
}
sub reset {
my $self = shift;
delete $self->{+_BREAK};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Term::Table::Cell - Representation of a cell in a table.
=head1 DESCRIPTION
This package is used to represent a cell in a table.
=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

130
Agent-Windows/OGP64/usr/share/perl5/5.40/Term/Table/CellStack.pm Normal file
View file

@ -0,0 +1,130 @@
package Term::Table::CellStack;
use strict;
use warnings;
our $VERSION = '0.018';
use Term::Table::HashBase qw/-cells -idx/;
use List::Util qw/max/;
sub init {
my $self = shift;
$self->{+CELLS} ||= [];
}
sub add_cell {
my $self = shift;
push @{$self->{+CELLS}} => @_;
}
sub add_cells {
my $self = shift;
push @{$self->{+CELLS}} => @_;
}
sub sanitize {
my $self = shift;
$_->sanitize(@_) for @{$self->{+CELLS}};
}
sub mark_tail {
my $self = shift;
$_->mark_tail(@_) for @{$self->{+CELLS}};
}
my @proxy = qw{
border_left border_right border_color value_color reset_color
border_left_width border_right_width
};
for my $meth (@proxy) {
no strict 'refs';
*$meth = sub {
my $self = shift;
$self->{+CELLS}->[$self->{+IDX}]->$meth;
};
}
for my $meth (qw{value_width width}) {
no strict 'refs';
*$meth = sub {
my $self = shift;
return max(map { $_->$meth } @{$self->{+CELLS}});
};
}
sub next {
my $self = shift;
my ($cw) = @_;
while ($self->{+IDX} < @{$self->{+CELLS}}) {
my $cell = $self->{+CELLS}->[$self->{+IDX}];
my $lw = $cell->border_left_width;
my $rw = $cell->border_right_width;
my $vw = $cw - $lw - $rw;
my $it = $cell->break->next($vw);
return ($it, $vw) if $it;
$self->{+IDX}++;
}
return;
}
sub break { $_[0] }
sub reset {
my $self = shift;
$self->{+IDX} = 0;
$_->reset for @{$self->{+CELLS}};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Term::Table::CellStack - Combine several cells into one (vertical)
=head1 DESCRIPTION
This package is used to represent a merged-cell in a table (vertical).
=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

473
Agent-Windows/OGP64/usr/share/perl5/5.40/Term/Table/HashBase.pm Normal file
View file

@ -0,0 +1,473 @@
package Term::Table::HashBase;
use strict;
use warnings;
our $VERSION = '0.018';
#################################################################
# #
# This is a generated file! Do not modify this file directly! #
# Use hashbase_inc.pl script to regenerate this file. #
# The script is part of the Object::HashBase distribution. #
# Note: You can modify the version number above this comment #
# if needed, that is fine. #
# #
#################################################################
{
no warnings 'once';
$Term::Table::HashBase::HB_VERSION = '0.008';
*Term::Table::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS;
*Term::Table::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST;
*Term::Table::HashBase::VERSION = \%Object::HashBase::VERSION;
*Term::Table::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE;
}
require Carp;
{
no warnings 'once';
$Carp::Internal{+__PACKAGE__} = 1;
}
BEGIN {
# these are not strictly equivalent, but for out use we don't care
# about order
*_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub {
no strict 'refs';
my @packages = ($_[0]);
my %seen;
for my $package (@packages) {
push @packages, grep !$seen{$_}++, @{"$package\::ISA"};
}
return \@packages;
}
}
my %SPEC = (
'^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1},
'-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1},
'>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1},
'<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
'+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
);
sub import {
my $class = shift;
my $into = caller;
# Make sure we list the OLDEST version used to create this class.
my $ver = $Term::Table::HashBase::HB_VERSION || $Term::Table::HashBase::VERSION;
$Term::Table::HashBase::VERSION{$into} = $ver if !$Term::Table::HashBase::VERSION{$into} || $Term::Table::HashBase::VERSION{$into} > $ver;
my $isa = _isa($into);
my $attr_list = $Term::Table::HashBase::ATTR_LIST{$into} ||= [];
my $attr_subs = $Term::Table::HashBase::ATTR_SUBS{$into} ||= {};
my %subs = (
($into->can('new') ? () : (new => \&_new)),
(map %{$Term::Table::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
(
map {
my $p = substr($_, 0, 1);
my $x = $_;
my $spec = $SPEC{$p} || {reader => 1, writer => 1};
substr($x, 0, 1) = '' if $spec->{strip};
push @$attr_list => $x;
my ($sub, $attr) = (uc $x, $x);
$attr_subs->{$sub} = sub() { $attr };
my %out = ($sub => $attr_subs->{$sub});
$out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader};
$out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer};
$out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only};
$out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer};
%out;
} @_
),
);
no strict 'refs';
*{"$into\::$_"} = $subs{$_} for keys %subs;
}
sub attr_list {
my $class = shift;
my $isa = _isa($class);
my %seen;
my @list = grep { !$seen{$_}++ } map {
my @out;
if (0.004 > ($Term::Table::HashBase::VERSION{$_} || 0)) {
Carp::carp("$_ uses an inlined version of Term::Table::HashBase too old to support attr_list()");
}
else {
my $list = $Term::Table::HashBase::ATTR_LIST{$_};
@out = $list ? @$list : ()
}
@out;
} reverse @$isa;
return @list;
}
sub _new {
my $class = shift;
my $self;
if (@_ == 1) {
my $arg = shift;
my $type = ref($arg);
if ($type eq 'HASH') {
$self = bless({%$arg}, $class)
}
else {
Carp::croak("Not sure what to do with '$type' in $class constructor")
unless $type eq 'ARRAY';
my %proto;
my @attributes = attr_list($class);
while (@$arg) {
my $val = shift @$arg;
my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor");
$proto{$key} = $val;
}
$self = bless(\%proto, $class);
}
}
else {
$self = bless({@_}, $class);
}
$Term::Table::HashBase::CAN_CACHE{$class} = $self->can('init')
unless exists $Term::Table::HashBase::CAN_CACHE{$class};
$self->init if $Term::Table::HashBase::CAN_CACHE{$class};
$self;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Term::Table::HashBase - Build hash based classes.
=head1 SYNOPSIS
A class:
package My::Class;
use strict;
use warnings;
# Generate 3 accessors
use Term::Table::HashBase qw/foo -bar ^baz <bat >ban +boo/;
# Chance to initialize defaults
sub init {
my $self = shift; # No other args
$self->{+FOO} ||= "foo";
$self->{+BAR} ||= "bar";
$self->{+BAZ} ||= "baz";
$self->{+BAT} ||= "bat";
$self->{+BAN} ||= "ban";
$self->{+BOO} ||= "boo";
}
sub print {
print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO;
}
Subclass it
package My::Subclass;
use strict;
use warnings;
# Note, you should subclass before loading HashBase.
use base 'My::Class';
use Term::Table::HashBase qw/bub/;
sub init {
my $self = shift;
# We get the constants from the base class for free.
$self->{+FOO} ||= 'SubFoo';
$self->{+BUB} ||= 'bub';
$self->SUPER::init();
}
use it:
package main;
use strict;
use warnings;
use My::Class;
# These are all functionally identical
my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar');
my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'});
my $three = My::Class->new(['MyFoo', 'MyBar']);
# Readers!
my $foo = $one->foo; # 'MyFoo'
my $bar = $one->bar; # 'MyBar'
my $baz = $one->baz; # Defaulted to: 'baz'
my $bat = $one->bat; # Defaulted to: 'bat'
# '>ban' means setter only, no reader
# '+boo' means no setter or reader, just the BOO constant
# Setters!
$one->set_foo('A Foo');
#'-bar' means read-only, so the setter will throw an exception (but is defined).
$one->set_bar('A bar');
# '^baz' means deprecated setter, this will warn about the setter being
# deprecated.
$one->set_baz('A Baz');
# '<bat' means no setter defined at all
# '+boo' means no setter or reader, just the BOO constant
$one->{+FOO} = 'xxx';
=head1 DESCRIPTION
This package is used to generate classes based on hashrefs. Using this class
will give you a C<new()> method, as well as generating accessors you request.
Generated accessors will be getters, C<set_ACCESSOR> setters will also be
generated for you. You also get constants for each accessor (all caps) which
return the key into the hash for that accessor. Single inheritance is also
supported.
=head1 THIS IS A BUNDLED COPY OF HASHBASE
This is a bundled copy of L<Object::HashBase>. This file was generated using
the
C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl>
script.
=head1 METHODS
=head2 PROVIDED BY HASH BASE
=over 4
=item $it = $class->new(%PAIRS)
=item $it = $class->new(\%PAIRS)
=item $it = $class->new(\@ORDERED_VALUES)
Create a new instance.
HashBase will not export C<new()> if there is already a C<new()> method in your
packages inheritance chain.
B<If you do not want this method you can define your own> you just have to
declare it before loading L<Term::Table::HashBase>.
package My::Package;
# predeclare new() so that HashBase does not give us one.
sub new;
use Term::Table::HashBase qw/foo bar baz/;
# Now we define our own new method.
sub new { ... }
This makes it so that HashBase sees that you have your own C<new()> method.
Alternatively you can define the method before loading HashBase instead of just
declaring it, but that scatters your use statements.
The most common way to create an object is to pass in key/value pairs where
each key is an attribute and each value is what you want assigned to that
attribute. No checking is done to verify the attributes or values are valid,
you may do that in C<init()> if desired.
If you would like, you can pass in a hashref instead of pairs. When you do so
the hashref will be copied, and the copy will be returned blessed as an object.
There is no way to ask HashBase to bless a specific hashref.
In some cases an object may only have 1 or 2 attributes, in which case a
hashref may be too verbose for your liking. In these cases you can pass in an
arrayref with only values. The values will be assigned to attributes in the
order the attributes were listed. When there is inheritance involved the
attributes from parent classes will come before subclasses.
=back
=head2 HOOKS
=over 4
=item $self->init()
This gives you the chance to set some default values to your fields. The only
argument is C<$self> with its indexes already set from the constructor.
B<Note:> Term::Table::HashBase checks for an init using C<< $class->can('init') >>
during construction. It DOES NOT call C<can()> on the created object. Also note
that the result of the check is cached, it is only ever checked once, the first
time an instance of your class is created. This means that adding an C<init()>
method AFTER the first construction will result in it being ignored.
=back
=head1 ACCESSORS
=head2 READ/WRITE
To generate accessors you list them when using the module:
use Term::Table::HashBase qw/foo/;
This will generate the following subs in your namespace:
=over 4
=item foo()
Getter, used to get the value of the C<foo> field.
=item set_foo()
Setter, used to set the value of the C<foo> field.
=item FOO()
Constant, returns the field C<foo>'s key into the class hashref. Subclasses will
also get this function as a constant, not simply a method, that means it is
copied into the subclass namespace.
The main reason for using these constants is to help avoid spelling mistakes
and similar typos. It will not help you if you forget to prefix the '+' though.
=back
=head2 READ ONLY
use Term::Table::HashBase qw/-foo/;
=over 4
=item set_foo()
Throws an exception telling you the attribute is read-only. This is exported to
override any active setters for the attribute in a parent class.
=back
=head2 DEPRECATED SETTER
use Term::Table::HashBase qw/^foo/;
=over 4
=item set_foo()
This will set the value, but it will also warn you that the method is
deprecated.
=back
=head2 NO SETTER
use Term::Table::HashBase qw/<foo/;
Only gives you a reader, no C<set_foo> method is defined at all.
=head2 NO READER
use Term::Table::HashBase qw/>foo/;
Only gives you a write (C<set_foo>), no C<foo> method is defined at all.
=head2 CONSTANT ONLY
use Term::Table::HashBase qw/+foo/;
This does not create any methods for you, it just adds the C<FOO> constant.
=head1 SUBCLASSING
You can subclass an existing HashBase class.
use base 'Another::HashBase::Class';
use Term::Table::HashBase qw/foo bar baz/;
The base class is added to C<@ISA> for you, and all constants from base classes
are added to subclasses automatically.
=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS
Term::Table::HashBase provides a function for retrieving a list of attributes for an
Term::Table::HashBase class.
=over 4
=item @list = Term::Table::HashBase::attr_list($class)
=item @list = $class->Term::Table::HashBase::attr_list()
Either form above will work. This will return a list of attributes defined on
the object. This list is returned in the attribute definition order, parent
class attributes are listed before subclass attributes. Duplicate attributes
will be removed before the list is returned.
B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to
determine the attribute to which each value will be paired.
=back
=head1 SOURCE
The source code repository for HashBase can be found at
F<http://github.com/Test-More/HashBase/>.
=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 2017 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

144
Agent-Windows/OGP64/usr/share/perl5/5.40/Term/Table/LineBreak.pm Normal file
View file

@ -0,0 +1,144 @@
package Term::Table::LineBreak;
use strict;
use warnings;
our $VERSION = '0.018';
use Carp qw/croak/;
use Scalar::Util qw/blessed/;
use Term::Table::Util qw/uni_length/;
use Term::Table::HashBase qw/string gcstring _len _parts idx/;
sub init {
my $self = shift;
croak "string is a required attribute"
unless defined $self->{+STRING};
}
sub columns { uni_length($_[0]->{+STRING}) }
sub break {
my $self = shift;
my ($len) = @_;
$self->{+_LEN} = $len;
$self->{+IDX} = 0;
my $str = $self->{+STRING} . ""; # Force stringification
my @parts;
my @chars = split //, $str;
while (@chars) {
my $size = 0;
my $part = '';
until ($size == $len) {
my $char = shift @chars;
$char = '' unless defined $char;
my $l = uni_length("$char");
last unless $l;
last if $char eq "\n";
if ($size + $l > $len) {
unshift @chars => $char;
last;
}
$size += $l;
$part .= $char;
}
# If we stopped just before a newline, grab it
shift @chars if $size == $len && @chars && $chars[0] eq "\n";
until ($size == $len) {
$part .= ' ';
$size += 1;
}
push @parts => $part;
}
$self->{+_PARTS} = \@parts;
}
sub next {
my $self = shift;
if (@_) {
my ($len) = @_;
$self->break($len) if !$self->{+_LEN} || $self->{+_LEN} != $len;
}
else {
croak "String has not yet been broken"
unless $self->{+_PARTS};
}
my $idx = $self->{+IDX}++;
my $parts = $self->{+_PARTS};
return undef if $idx >= @$parts;
return $parts->[$idx];
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Term::Table::LineBreak - Break up lines for use in tables.
=head1 DESCRIPTION
This is meant for internal use. This package takes long lines of text and
splits them so that they fit in table rows.
=head1 SYNOPSIS
use Term::Table::LineBreak;
my $lb = Term::Table::LineBreak->new(string => $STRING);
$lb->break($SIZE);
while (my $part = $lb->next) {
...
}
=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

15
Agent-Windows/OGP64/usr/share/perl5/5.40/Term/Table/Spacer.pm Normal file
View file

@ -0,0 +1,15 @@
package Term::Table::Spacer;
use strict;
use warnings;
our $VERSION = '0.018';
sub new { bless {}, $_[0] }
sub width { 1 }
sub sanitize { }
sub mark_tail { }
sub reset { }
1;

200
Agent-Windows/OGP64/usr/share/perl5/5.40/Term/Table/Util.pm Normal file
View file

@ -0,0 +1,200 @@
package Term::Table::Util;
use strict;
use warnings;
use Config qw/%Config/;
our $VERSION = '0.018';
use base 'Exporter';
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