our
$VERSION
=
"1.44"
;
use
open
IO
=>
'utf8'
,
':std'
;
ExConfigure
BASECLASS
=> [ __PACKAGE__,
"Getopt::EX"
];
Configure
qw(bundling)
;
my
%DEFAULT_COLORMAP
= (
BORDER
=>
''
,
TEXT
=>
''
,
);
Getopt::EX::Hashed->configure(
DEFAULT
=> [
is
=>
'rw'
] );
has
debug
=>
' '
;
has
help
=>
' h '
;
has
version
=>
' v '
;
has
width
=>
' =s w c '
;
has
fillrows
=>
' x '
;
has
table
=>
' t '
;
has
table_columns_limit
=>
' =i l '
,
default
=> 0 ;
has
table_align
=>
' ! A '
;
has
table_tabs
=>
' + T '
;
has
table_right
=>
' =s R '
,
default
=>
''
;
has
separator
=>
' =s s '
,
default
=>
' '
;
has
regex_sep
=>
' r '
;
has
output_separator
=>
' =s o '
,
default
=>
' '
;
has
document
=>
' D '
;
has
parallel
=>
' ! V '
;
has
filename
=>
' ! H '
;
has
filename_format
=>
' =s '
,
default
=>
': %s'
;
has
ignore_empty
=>
' ! I '
,
default
=> 0 ;
has
pages
=>
' ! '
;
has
up
=>
' :s U '
;
has
page
=>
' :i P '
,
min
=> 0;
has
pane
=>
' =s C '
,
default
=> 0 ;
has
cell
=>
' =s X '
;
has
pane_width
=>
' =s S pw '
;
has
widen
=>
' ! W '
;
has
paragraph
=>
' ! p '
;
has
height
=>
' =s '
,
default
=> 0 ;
has
column_unit
=>
' =i cu '
,
min
=> 1,
default
=> 8 ;
has
margin
=>
' =i '
,
min
=> 0,
default
=> 1 ;
has
tabstop
=>
' =i '
,
min
=> 1,
default
=> 8 ;
has
tabhead
=>
' =s '
;
has
tabspace
=>
' =s '
;
has
tabstyle
=>
' :s ts '
;
has
ignore_space
=>
' ! is '
,
default
=> 1 ;
has
linestyle
=>
' =s ls '
,
default
=>
''
;
has
boundary
=>
' =s '
,
default
=>
''
;
has
linebreak
=>
' =s lb '
,
default
=>
''
;
has
runin
=>
' =i '
,
min
=> 0,
default
=> 2 ;
has
runout
=>
' =i '
,
min
=> 0,
default
=> 2 ;
has
runlen
=>
' =i '
;
has
pagebreak
=>
' ! '
,
default
=> 1 ;
has
border
=>
' :s '
;
has
B
=>
''
,
action
=>
sub
{
$_
->border =
''
} ;
has
no_border
=>
' '
,
action
=>
sub
{
$_
->border =
'none'
} ;
has
border_style
=>
' =s bs '
,
default
=>
'box'
;
has
white_space
=>
' ! '
,
default
=> 2 ;
has
isolation
=>
' ! '
,
default
=> 2 ;
has
fillup
=>
' :s '
;
has
F
=>
''
,
action
=>
sub
{
$_
->fillup =
''
} ;
has
fillup_str
=>
' :s '
,
default
=>
''
;
has
ambiguous
=>
' =s '
,
default
=>
'narrow'
;
has
discard_el
=>
' ! '
,
default
=> 1 ;
has
padchar
=>
' =s '
,
default
=>
' '
;
has
colormap
=>
' =s@ cm '
,
default
=> [] ;
has
'+boundary'
=>
any
=> [
qw(none word space)
] ;
has
'+linestyle'
=>
any
=> [
qw(none wordwrap wrap truncate)
] ;
has
'+fillup'
=>
any
=> [
qw(pane page none)
,
''
] ;
has
'+ambiguous'
=>
any
=> [
qw(wide narrow)
] ;
my
$nup
=
sub
{
$_
[0] =~ /^(\d+)/ and
$_
->up = $1 } ;
for
my
$n
(2..9) {
has
"${n}up"
=>
''
,
action
=>
$nup
;
}
has
span
=> ;
has
panes
=> ;
has
border_height
=> ;
has
current_page
=> ;
Getopt::EX::Hashed->configure(
DEFAULT
=> [] );
has
'+help'
=>
sub
{
pod2usage
-verbose
=> 99,
-sections
=> [
qw(SYNOPSIS VERSION)
];
};
has
'+version'
=>
sub
{
say
"Version: $VERSION"
;
exit
;
};
has
[
qw(+height +width +pane +up +pane_width)
] =>
sub
{
my
$obj
=
$_
;
my
(
$name
,
$val
) =
@_
;
$obj
->
$name
=
$val
!~ /\D/ ?
$val
:
do
{
my
$init
=
$name
=~ /height/ ?
$obj
->term_height :
$obj
->term_width;
rpn_calc(
$init
,
$val
) //
die
"$val: invalid $name.\n"
;
};
};
has
'+ambiguous'
=>
sub
{
if
(
$_
[1] eq
'wide'
) {
$Text::VisualWidth::PP::EastAsian
= 1;
Text::ANSI::Fold->configure(
ambiguous
=>
'wide'
);
}
};
has
'+runlen'
=>
sub
{
$_
->runin =
$_
->runout =
$_
[1];
};
has
run
=>
'=i'
;
has
'+run'
=>
sub
{
$_
->runin =
$_
->runout =
$_
[1];
};
has
[
qw(+tabstop +tabstyle)
] =>
sub
{
my
(
$name
,
$val
) =
map
"$_"
,
@_
;
if
(
$val
eq
''
) {
list_tabstyle();
exit
;
}
Text::ANSI::Fold->configure(
$name
=>
$val
);
};
has
[
qw(+tabhead +tabspace)
] =>
sub
{
my
(
$name
,
$c
) =
map
"$_"
,
@_
;
$c
= charnames::string_vianame(
$c
) ||
die
"$c: invalid name\n"
if
length
(
$c
) > 1;
Text::ANSI::Fold->configure(
$name
=>
$c
);
};
has
'+table_align'
=>
sub
{
if
(
$_
->table_align =
$_
[1]) {
$_
->table =
$_
[1];
}
};
has
'+table_tabs'
=>
sub
{
$_
->table_tabs +=
$_
[1];
if
(
$_
->table_tabs == 1) {
$_
->table =
$_
->table_align =
$_
[1];
}
elsif
(
$_
->table_tabs == 2) {
$_
->regex_sep = 1;
$_
->separator =
'\\t+'
;
}
};
has
TERM_SIZE
=> ;
has
COLORHASH
=>
default
=> {
%DEFAULT_COLORMAP
};
has
COLORLIST
=>
default
=> [];
has
COLOR
=> ;
has
BORDER
=> ;
}
no
Getopt::EX::Hashed;
sub
list_tabstyle {
my
%style
=
%Text::ANSI::Fold::TABSTYLE
;
my
$max
= max
map
length
,
keys
%style
;
for
my
$name
(
sort
keys
%style
) {
my
(
$head
,
$space
) = @{
$style
{
$name
}};
printf
"%*s %s%s\n"
,
$max
,
$name
,
$head
,
$space
x 7;
}
}
sub
perform {
my
$obj
=
shift
;
local
@ARGV
= decode_argv(
@_
);
$obj
->getopt || pod2usage(2);
$obj
->setup_options;
warn
Dumper
$obj
if
$obj
->debug;
my
@files
=
$obj
->read_files(
@ARGV
?
@ARGV
:
'-'
) or
return
1;
if
(
$obj
->ignore_empty) {
@files
=
grep
{ @{
$_
->{data}} > 0 }
@files
;
}
if
(
$obj
->table) {
my
@lines
=
map
{ @{
$_
->{data}} }
@files
;
$obj
->table_out(
@lines
);
}
elsif
(
$obj
->parallel) {
$obj
->parallel_out(
@files
);
}
else
{
$obj
->nup_out(
@files
);
}
return
0
}
sub
setup_options {
my
$obj
=
shift
;
if
(
$obj
->parallel //=
@ARGV
> 1) {
$obj
->linestyle ||=
'wrap'
;
$obj
->widen //= 1;
$obj
->border //=
''
;
}
if
(
defined
(
my
$border
=
$obj
->border)) {
if
(
$border
ne
''
) {
$obj
->border_style =
$border
;
}
$obj
->border = 1;
$obj
->fillup //=
'pane'
;
}
if
(
$obj
->linestyle eq
'wordwrap'
) {
$obj
->linestyle =
'wrap'
;
$obj
->boundary =
'word'
;
}
if
(
defined
$obj
->page) {
$obj
->widen = 1
if
$obj
->pane and not
$obj
->pane_width;
$obj
->height ||=
$obj
->page ||
$obj
->term_height - 1;
$obj
->linestyle ||=
'wrap'
;
$obj
->border //= 1;
$obj
->fillup //=
'pane'
;
}
if
(
$obj
->up) {
$obj
->pane =
$obj
->up;
$obj
->widen = 1;
$obj
->linestyle ||=
'wrap'
;
$obj
->border //= 1;
$obj
->fillup //=
'pane'
;
}
if
(
$obj
->document) {
$obj
->widen = 1;
$obj
->linebreak ||=
'all'
;
$obj
->linestyle ||=
'wrap'
;
$obj
->boundary ||=
'word'
;
$obj
->white_space = 0
if
$obj
->white_space > 1;
$obj
->isolation = 0
if
$obj
->isolation > 1;
}
my
$cm
= Getopt::EX::Colormap
->new(
HASH
=>
$obj
->{COLORHASH},
LIST
=>
$obj
->{COLORLIST})
->load_params(@{
$obj
->colormap});
$obj
->{COLOR} =
sub
{
$cm
->color(
@_
) };
if
(
$obj
->border) {
my
$style
=
$obj
->border_style;
(
$obj
->{BORDER} = App::ansicolumn::Border->new)
->style(
$style
) //
die
"$style: Unknown style.\n"
;
}
$obj
;
}
sub
color {
my
$obj
=
shift
;
$obj
->{COLOR}->(
@_
);
}
sub
parallel_out {
my
$obj
=
shift
;
my
@files
=
@_
;
my
$max_line_length
= max
map
{
$_
->{
length
} }
@files
;
$obj
->pane ||=
@files
;
$obj
->set_horizontal(
$max_line_length
);
if
(
my
$cell
=
$obj
->cell) {
my
@spans
=
split
/,+/,
$cell
;
for
my
$i
(
keys
@files
) {
my
$span
=
$spans
[
$i
] //
$spans
[-1];
if
(
$span
=~ /^[-+]/) {
$span
+=
$obj
->{span};
$span
< 0 and
die
"Invalid number: $cell\n"
;
}
elsif
(
$span
=~ s/^(<=|[<=])//) {
my
$length
=
$files
[
$i
]->{
length
};
$span
=
$span
? min(
$length
,
$span
) :
$length
;
}
elsif
(
$span
!~ /^\d+$/) {
die
"Invalid number: $cell\n"
;
}
$files
[
$i
]->{span} =
$span
;
}
}
$obj
->set_contents(
$_
)
for
@files
;
while
(
@files
) {
my
@rows
=
splice
@files
, 0,
$obj
->pane;
my
$max_length
= max
map
{
int
@{
$_
->{data}} }
@rows
;
my
@span
=
map
{
$_
->{span} //
$obj
->span }
@rows
;
if
(
$obj
->filename) {
my
$w
=
$obj
->span +
$obj
->border_width(
'center'
);
my
$format
=
join
''
, (
(
map
{
my
$w
=
$_
+
$obj
->border_width(
'center'
);
"%-${w}.${w}s"
;
}
@span
[0..
$#span
-1]),
"%s\n"
);
ansi_printf
$format
,
map
{
ansi_sprintf
$obj
->filename_format,
$_
->{name};
}
@rows
;
}
$obj
->column_out(
{
span
=> \
@span
},
map
{
my
$data
=
$_
->{data};
my
$length
=
@$data
;
push
@$data
, ((
$obj
->fillup_str) x (
$max_length
-
$length
));
$data
;
}
@rows
);
}
return
$obj
;
}
sub
nup_out {
my
$obj
=
shift
;
my
@files
=
@_
;
my
$max_length
= max
map
{
$_
->{
length
} }
@files
;
$obj
->set_horizontal(
$max_length
);
my
$reset
=
do
{
my
@o
=
%$obj
;
sub
{
%$obj
=
@o
} };
for
my
$file
(
@files
) {
my
$data
=
$file
->{data};
next
if
@$data
== 0;
$obj
->set_contents(
$file
)
->set_vertical(
$data
)
->set_layout(
$data
)
->page_out(
@$data
);
$reset
->();
}
return
$obj
;
}
sub
read_files {
my
$obj
=
shift
;
my
@files
;
for
my
$file
(
@_
) {
open
my
$fh
,
$file
or
die
"$file: $!"
;
my
$content
=
do
{
local
$/; <
$fh
> } //
do
{
warn
"$file: $!\n"
if
$!;
next
;
};
my
@data
=
$obj
->pages ?
split
(/\f/,
$content
) :
$content
;
for
my
$data
(
@data
) {
my
@line
=
split
/\n/,
$data
;
@line
= insert_space
@line
if
$obj
->paragraph;
my
$length
=
do
{
if
(
$obj
->table) {
max
map
length
,
@line
;
}
else
{
$obj
->expand_tab(\
@line
, \
my
@length
);
max
@length
;
}
};
push
@files
, {
name
=>
$file
,
length
=>
$length
// 0,
data
=> \
@line
,
};
}
}
@files
;
}
sub
expand_tab {
my
$obj
=
shift
;
my
(
$dp
,
$lp
) =
@_
;
for
(
@$dp
) {
(
$_
,
my
(
$dmy
,
$length
)) = ansi_fold
$_
, -1,
expand
=> 1;
push
@$lp
,
$length
;
}
}
sub
set_horizontal {
my
$obj
=
shift
;
my
$max_data_length
=
shift
;
my
$width
=
$obj
->get_width -
$obj
->border_width(
qw(left right)
);
my
$unit
=
$obj
->column_unit // 1;
my
$span
;
my
$panes
;
my
$claim
= sum(
$max_data_length
,
$obj
->runin_margin,
$obj
->border_width(
'center'
) ||
$obj
->margin);
if
(
$obj
->widen and not
$obj
->pane_width) {
$panes
=
$obj
->pane ||
$width
/
$claim
|| 1;
$span
= (
$width
+
$obj
->border_width(
'center'
)) /
$panes
;
}
else
{
$span
=
$obj
->pane_width || roundup(
$claim
,
$unit
);
$panes
=
$obj
->pane ||
$width
/
$span
|| 1;
}
$span
-=
$obj
->border_width(
'center'
);
$span
< 1 and
die
"Not enough space.\n"
;
(
$obj
->span,
$obj
->panes) = (
$span
,
$panes
);
return
$obj
;
}
sub
set_contents {
my
$obj
=
shift
;
my
$fp
=
shift
;
my
$dp
=
$fp
->{data};
(
my
$cell_width
=
$obj
->span -
$obj
->runin_margin) < 1
and
die
"Not enough space.\n"
;
if
(
$obj
->linestyle and
$obj
->linestyle ne
'none'
) {
my
$w
=
$fp
->{span} //
$cell_width
;
my
$fold
=
$obj
->foldsub(
$w
) or
die
;
@$dp
=
map
{
$fold
->(
$_
) }
@$dp
;
}
return
$obj
;
}
sub
set_vertical {
my
$obj
=
shift
;
my
$dp
=
shift
;
$obj
->border_height =
do
{
sum
map
{
length
> 0 }
map
{
$obj
->get_border(
$_
) }
qw(top bottom)
;
};
$obj
->height ||= div(
int
@$dp
,
$obj
->panes) +
$obj
->border_height;
die
"Not enough height.\n"
if
$obj
->effective_height <= 0;
return
$obj
;
}
sub
page_out {
my
$obj
=
shift
;
for
(
$obj
->current_page = 0;
@_
;
$obj
->current_page++) {
my
@columns
=
grep
{
@$_
}
do
{
if
(
$obj
->fillrows) {
xpose
map
{ [
splice
@_
, 0,
$obj
->panes ] } 1 ..
$obj
->effective_height;
}
else
{
map
{ [
splice
@_
, 0,
$obj
->effective_height ] } 1 ..
$obj
->panes;
}
};
$obj
->column_out(
@columns
);
}
return
$obj
;
}
sub
color_border {
my
$obj
=
shift
;
$obj
->color(
'BORDER'
,
$obj
->get_border(
@_
));
}
sub
column_out {
my
$obj
=
shift
;
my
$opt
=
ref
$_
[0] eq
'HASH'
?
shift
: {};
my
@span
=
$opt
->{span} ? @{
$opt
->{span}} : ((
$obj
->{span}) x
@_
);
@span
==
@_
or
die
;
my
%bd
=
map
{
$_
=>
$obj
->get_border(
$_
) }
qw(top bottom)
;
if
(
$bd
{top} or
$bd
{bottom}) {
while
(
my
(
$i
,
$e
) =
each
@_
) {
unshift
@$e
,
$obj
->color(
'BORDER'
,
$bd
{top} x
$span
[
$i
])
if
$bd
{top};
push
@$e
,
$obj
->color(
'BORDER'
,
$bd
{bottom} x
$span
[
$i
])
if
$bd
{bottom};
}
}
my
$max
= max
map
$
for
my
$i
(0 ..
$max
) {
my
$pos
=
$i
== 0 ? 0 :
$i
==
$max
? 2 : 1;
my
@span
=
@span
;
my
@panes
=
map
{
@$_
? ansi_sprintf(
"%-*s"
,
shift
@span
,
shift
@$_
) : ();
}
@_
;
print
$obj
->color_border(
'left'
,
$pos
,
$obj
->current_page);
print
join
$obj
->color_border(
'center'
,
$pos
,
$obj
->current_page),
map
{
$obj
->color(
'TEXT'
,
$_
) }
@panes
;
print
$obj
->color_border(
'right'
,
$pos
,
$obj
->current_page);
print
"\n"
;
}
return
$obj
;
}
sub
_numbers {
Getopt::EX::Numbers->new(
min
=> 1,
@_
);
}
sub
table_out {
my
$obj
=
shift
;
return
unless
@_
;
my
$split
=
do
{
if
(
$obj
->separator eq
' '
) {
$obj
->ignore_space ?
' '
:
qr/\s+/
;
}
elsif
(
$obj
->regex_sep) {
qr($obj->{separator})
;
}
else
{
qr/[\Q$obj->{separator}\E]/
;
}
};
my
@lines
=
map
{ [
split
$split
,
$_
,
$obj
->table_columns_limit ] }
@_
;
my
@length
=
map
{ [
map
{ ansi_width
$_
}
@$_
] }
@lines
;
my
@max
=
map
{ max
@$_
} xpose
@length
;
if
(
$obj
->table_align) {
my
@tabs
=
map
{ roundup
$_
,
$obj
->column_unit,
$obj
->margin }
@max
;
if
(
$obj
->table_tabs) {
my
$cu
=
$obj
->column_unit;
while
(
my
(
$lx
,
$l
) =
each
@lines
) {
while
(
my
(
$fx
,
$f
) =
each
@$l
) {
print
$f
;
if
(
$fx
== $
print
"\n"
;
}
else
{
print
"\t"
x div(
$tabs
[
$fx
] -
$length
[
$lx
][
$fx
],
$cu
);
}
}
}
return
$obj
;
}
@max
=
map
{
$_
-
$obj
->margin }
@tabs
;
$obj
->output_separator =
' '
x
$obj
->margin;
}
my
@align
= newlist(
count
=>
int
@max
,
default
=>
'-'
,
[
map
--
$_
,
map
{
_numbers(
max
=>
int
@max
)->parse(
$_
)->sequence
}
split
/,/,
$obj
->table_right ] =>
''
);
my
@format
=
map
"%$align[$_]$max[$_]s"
,
keys
@max
;
for
my
$line
(
@lines
) {
next
unless
@$line
;
my
@fmt
=
@format
[
keys
@$line
];
$fmt
[
$#fmt
] =
'%s'
if
$align
[
$#fmt
] eq
'-'
;
my
$format
=
join
(
$obj
->output_separator,
@fmt
) .
"\n"
;
ansi_printf
$format
,
@$line
;
}
return
$obj
;
}
1;