File Coverage

blib/lib/Text/ANSI/Fold.pm

Criterion	Covered	Total	%
statement	271	290	93.4
branch	137	162	84.5
condition	54	75	72.0
subroutine	39	40	97.5
pod	7	19	36.8
total	508	586	86.6

package Text::ANSI::Fold;

use v5.14;
use warnings;
use utf8;

our $VERSION = "2.3305";

use Data::Dumper;
{
    no warnings 'redefine';
    *Data::Dumper::qquote = sub { qq["${\(shift)}"] };
    $Data::Dumper::Useperl = 1;
    $Data::Dumper::Sortkeys = 1;
}
use Carp;
use List::Util qw(pairmap pairgrep);
use Scalar::Util qw(looks_like_number);
use Text::VisualWidth::PP 'vwidth';

######################################################################
use Exporter 'import';
our %EXPORT_TAGS = (
    constants => [ qw(
	&LINEBREAK_NONE
	&LINEBREAK_ALL
	&LINEBREAK_RUNIN
	&LINEBREAK_RUNOUT
	) ],
    regex => [ qw(
	$reset_re
	$color_re
	$erase_re
	$csi_re
	$osc_re
	) ],
    );

our @EXPORT_OK = ( qw(&ansi_fold),
		   @{$EXPORT_TAGS{constants}},
		   @{$EXPORT_TAGS{regex}},
    );

sub ansi_fold {
    my($text, $width, @option) = @_;
    __PACKAGE__->fold($text, width => $width, @option);
}
######################################################################

our $alphanum_re = qr{ [_\d\p{Latin}\p{Greek}\p{Cyrillic}\p{Hangul}] }x;
our $nonspace_re = qr{ \p{IsPrintableLatin} }x;
our $reset_re    = qr{ \e \[ [0;]* m }x;
our $color_re    = qr{ \e \[ [\d;]* m }x;
our $erase_re    = qr{ \e \[ [\d;]* K }x;

# see ECMA-48 5.4 Control sequences
my  $csi_start       = qr{ (?: \e\[ | \x9b ) }x;
my  $csi_parameter   = qr/[\x30-\x3f]*+/;
my  $csi_itermidiate = qr/[\x20-\x2f]*+/;
my  $csi_final       = qr/[\x40-\x7e]/;
our $csi_body_re     = qr/${csi_start}${csi_parameter}${csi_itermidiate}/;
our $csi_re          = qr/${csi_start}${csi_parameter}${csi_itermidiate}${csi_final}/;

our $osc_re          = qr{
    # see ECMA-48 8.3.89 OSC - OPERATING SYSTEM COMMAND
    # Extended to accept non-ASCII (undefined but tolerated)
    (?: \e\] | \x9d )			  # osc
    [^\x00-\x07\x0e-\x1f\x7f-\x9f]*+	  # command (excludes C1 controls)
    (?: \e\\ | \x9c | \a )		  # st: string terminator
}x;

use constant SGR_RESET  => "\e[m";
use constant OSC8_RESET => "\e]8;;\e\\";

sub pwidth { vwidth $_[0] =~ s/\X\cH{1,2}//gr =~ s/${osc_re}//gr }

sub IsPrintableLatin {
    return <<"END";
+utf8::ASCII
+utf8::Latin
-utf8::White_Space
END
}

sub IsWideSpacing {
    return <<"END";
+utf8::East_Asian_Width=Wide
+utf8::East_Asian_Width=FullWidth
-utf8::Nonspacing_Mark
-utf8::Default_Ignorable_Code_Point
END
}

sub IsWideAmbiguousSpacing {
    return <<"END";
+utf8::East_Asian_Width=Wide
+utf8::East_Asian_Width=FullWidth
+utf8::East_Asian_Width=Ambiguous
-utf8::Nonspacing_Mark
-utf8::Default_Ignorable_Code_Point
END
}

sub _startWideSpacing {
    # look at $_
    if ($Text::VisualWidth::PP::EastAsian) {
	/^\p{IsWideAmbiguousSpacing}/;
    } else {
	/^\p{IsWideSpacing}/;
    }
}

use constant {
    LINEBREAK_NONE   => 0,
    LINEBREAK_RUNIN  => 1,
    LINEBREAK_RUNOUT => 2,
    LINEBREAK_ALL    => 3,
};

our $DEFAULT_LINEBREAK = LINEBREAK_NONE;
our $DEFAULT_RUNIN_WIDTH  = 2;
our $DEFAULT_RUNOUT_WIDTH = 2;

BEGIN {
    if ($] < 5.016) {
	require charnames;
	charnames->import(':full');
    }
}

our %TABSTYLE = (
    pairmap {
	( $a =~ s/_/-/gr => ref $b ? $b : [ $b, $b ] );
    }
    symbol   => [ "\N{SYMBOL FOR HORIZONTAL TABULATION}",		    # ␉
		  "\N{SYMBOL FOR SPACE}" ],				    # ␠
    shade    => [ "\N{MEDIUM SHADE}",					    # ▒
		  "\N{LIGHT SHADE}" ],					    # ░
    block    => [ "\N{LOWER ONE QUARTER BLOCK}",			    # ▂
		  "\N{LOWER ONE EIGHTH BLOCK}" ],			    # ▁
    needle   => [ "\N{BOX DRAWINGS HEAVY RIGHT}",			    # ╺
		  "\N{BOX DRAWINGS LIGHT HORIZONTAL}" ],		    # ─
    dash     => [ "\N{BOX DRAWINGS HEAVY RIGHT}",			    # ╺
		  "\N{BOX DRAWINGS LIGHT DOUBLE DASH HORIZONTAL}" ],	    # ╌
    triangle => [ "\N{BLACK RIGHT-POINTING SMALL TRIANGLE}",		    # ▸
		  "\N{WHITE RIGHT-POINTING SMALL TRIANGLE}" ],		    # ▹

    dot          => '.',
    space        => ' ',
    emspace      => "\N{EM SPACE}",					    #
    blank        => "\N{OPEN BOX}",					    # ␣
    middle_dot   => "\N{MIDDLE DOT}",					    # ·
    arrow        => "\N{RIGHTWARDS ARROW}",				    # →
    double_arrow => "\N{RIGHTWARDS DOUBLE ARROW}",			    # ⇒
    triple_arrow => "\N{RIGHTWARDS TRIPLE ARROW}",			    # ⇛
    white_arrow  => "\N{RIGHTWARDS WHITE ARROW}",			    # ⇨
    wave_arrow   => "\N{RIGHTWARDS WAVE ARROW}",			    # ↝
    circle_arrow => "\N{CIRCLED HEAVY WHITE RIGHTWARDS ARROW}",		    # ➲
    curved_arrow => "\N{HEAVY BLACK CURVED DOWNWARDS AND RIGHTWARDS ARROW}",# ➥
    shadow_arrow => "\N{HEAVY UPPER RIGHT-SHADOWED WHITE RIGHTWARDS ARROW}",# ➮
    squat_arrow  => "\N{SQUAT BLACK RIGHTWARDS ARROW}",			    # ➧
    squiggle     => "\N{RIGHTWARDS SQUIGGLE ARROW}",			    # ⇝
    harpoon      => "\N{RIGHTWARDS HARPOON WITH BARB UPWARDS}",		    # ⇀
    cuneiform    => "\N{CUNEIFORM SIGN TAB}",				    # 𒋰

    );

for my $alias (
    [ bar => 'needle'],
    [ pin => 'needle']
) {
    $TABSTYLE{$alias->[0]} = $TABSTYLE{$alias->[1]};
}

my @default = (
    text      => '',
    width     => undef,
    padding   => 0,
    boundary  => '',
    padchar   => ' ',
    prefix    => '',
    ambiguous => 'narrow',
    margin    => 0,
    linebreak => $DEFAULT_LINEBREAK,
    runin     => $DEFAULT_RUNIN_WIDTH,
    runout    => $DEFAULT_RUNOUT_WIDTH,
    expand    => 0,
    tabstop   => 8,
    tabhead   => ' ',
    tabspace  => ' ',
    discard   => {},
    splitwide => 0,
    lefthalf  => "\N{NO-BREAK SPACE}",
    righthalf => "\N{NO-BREAK SPACE}",
    );

sub new {
    my $class = shift;
    my $obj = bless { @default }, $class;
    $obj->configure(@_) if @_;
    $obj;
}

INTERNAL_METHODS: {
    sub spawn {
	my $obj = shift;
	my $class = ref $obj;
	my %new = ( %$obj, pairgrep { defined $b } @_ );
	bless \%new, $class;
    }
    sub do_runin  { $_[0]->{linebreak} & LINEBREAK_RUNIN  && $_[0]->{runin}  > 0 }
    sub do_runout { $_[0]->{linebreak} & LINEBREAK_RUNOUT && $_[0]->{runout} > 0 }
}

use Text::ANSI::Fold::Japanese::W3C qw(%prohibition);

sub chars_to_regex {
    my $chars = join '', @_;
    my($c, @s);
    for ($chars =~ /\X/g) {
	if (length == 1) {
	    $c .= $_;
	} else {
	    push @s, $_;
	}
    }
    if (@s) {
	local $" = '|';
	qr/(?:[\Q$c\E]|@s)/;
    } else {
	qr/[\Q$c\E]/;
    }
}

my %prohibition_re = do {
    head => do {
	my $re = chars_to_regex @prohibition{qw(head postfix)};
	qr/(?: $re | \p{Space_Separator} )/x;
    },
    end  => chars_to_regex @prohibition{qw(end prefix)},
};

sub configure {
    my $obj = shift;
    if (not ref $obj) {
	$obj = state $private = __PACKAGE__->new;
    }
    croak "invalid parameter" if @_ % 2;
    while (@_ >= 2) {
	my($a, $b) = splice @_, 0, 2;

	if ($a eq 'tabstyle') {
	    $b // next;
	    my($h, $s) = $b =~ /([-\w]+)/g or croak "$b: invalid tabstyle";
	    $s ||= $h;
	    my %style = (
		h => ($TABSTYLE{$h} or croak "$h: invalid tabstyle"),
		s => ($TABSTYLE{$s} or croak "$s: invalid tabstyle"),
		);
	    unshift @_,
		tabhead  => $style{h}->[0],
		tabspace => $style{s}->[1];
	    next;
	}

	croak "$a: invalid parameter" if not exists $obj->{$a};
	$obj->{$a} = $b;
    }
    if (ref $obj->{discard} eq 'ARRAY') {
	$obj->{discard} = { map { uc $_ => 1 } @{$obj->{discard}} };
    }
    $obj;
}

my @color_stack;
my @bg_stack;
my @reset;
my $osc8_link;
sub put_reset { @reset = shift };
sub pop_reset {
    @reset ? do { @color_stack = (); pop @reset } : '';
}

use constant MAX_INT => ~0 >> 1;

sub IsEOL {
    <<"END";
0000\t0000
000A\t000D
2028\t2029
END
}

sub fold {
    my $obj = shift;
    local $_ = shift // '';

    if (not ref $obj) {
	$obj = state $private = configure();
    }
    my $opt = $obj->spawn(splice @_);

    my $width = $opt->{width};
    looks_like_number $width and $width == int($width)
	or croak "$width: invalid width";
    $opt->{padding} = 0 if $width <= 0;
    $width = MAX_INT    if $width <  0;
    ($width -= $opt->{margin}) > 0 or croak "margin too big";

    my $word_char_re =
	    { word => $alphanum_re, space => $nonspace_re }
	    ->{$opt->{boundary} // ''};

    local $Text::VisualWidth::PP::EastAsian = $opt->{ambiguous} eq 'wide';

    my $folded = '';
    my $eol = '';
    my $room = $width;
    @bg_stack = @color_stack = @reset = ();
    $osc8_link = undef;
    my $unremarkable_re =
	$opt->{expand} ? qr/[^\p{IsEOL}\e\t]/
		       : qr/[^\p{IsEOL}\e]/;

  FOLD:
    while (length) {

	# newline, null, vt
	# U+2028: Line Separator
	# U+2029: Paragraph Separator
	if (s/\A(\r*\n|[\0\x0b\N{U+2028}\N{U+2029}])//) {
	    $eol = $1;
	    last;
	}
	# form feed
	if (m/\A(\f+)/p) {
	    last if length $folded;
	    ($folded, $_) = ($1, ${^POSTMATCH});
	    next;
	}
	# carriage return
	if (s/\A(\r+)//) {
	    if (length == 0) {
		# this must be the part of CRNL
		$eol = $1;
		last;
	    } else {
		$folded .= $1;
		$room = $width;
		next;
	    }
	}
	# ECMA-48 OPERATING SYSTEM COMMAND
	if (s/\A($osc_re)//) {
	    my $osc = $1;
	    unless ($obj->{discard}->{OSC}) {
		$folded .= $osc;
		if ($osc =~ /^(?:\e\]|\x9d)8;[^;]*;(.*?)(?:\e\\|\x9c|\a)$/) {
		    $osc8_link = $1 ne '' ? $osc : undef;
		}
	    }
	    next;
	}
	# erase line (assume 0)
	if (s/\A($erase_re)//) {
	    $folded .= $1 unless $obj->{discard}->{EL};
	    @bg_stack = grep { !/$erase_re/ } @color_stack;
	    push @color_stack, $1;
	    next;
	}
	# reset
	if (s/\A($reset_re+($erase_re*))//) {
	    put_reset($1);
	    @bg_stack = () if $2;
	    next;
	}

	last if $room < 1;
	if ($room < 2 and !$opt->{splitwide}) {
	    last if $room != $width and &_startWideSpacing;
	}

	if (@reset) {
	    $folded .= pop_reset();
	}

	# ANSI color sequence
	if (s/\A($color_re)//) {
	    $folded .= $1;
	    push @color_stack, $1;
	    next;
	}

	# imcomplete CSI
	if (s/\A(\e+|$csi_body_re)\z//) {
	    $folded .= $1;
	    last;
	}

	# tab
	if ($opt->{expand} and s/\A\t//) {
	    my $space = $opt->{tabstop} - ($width - $room) % $opt->{tabstop};
	    $_ = $opt->{tabhead} . $opt->{tabspace} x ($space - 1) . $_;
	    next;
	}

	# backspace
	my $bs = 0;
	while (m/\A(?:\X\cH+)++(?\X|\z)/p) {
	    my $w = vwidth($+{c});
	    last FOLD if $w > $room and $room != $width;
	    $folded .= ${^MATCH};
	    $_ = ${^POSTMATCH};
	    $room -= $w;
	    $bs++;
	    last FOLD if $room < 0;
	    last      if $room < 1;
	}
	next if $bs;

	# consume unremarkable characters
	if (s/\A(\e+|(?:${unremarkable_re}(?!\cH))+)//) {
	    my $s = $1;
	    if ((my $w = vwidth($s)) <= $room) {
		$folded .= $s;
		$room -= $w;
		next;
	    }
	    my($a, $b, $w) = simple_fold($s, $room);
	    if ($opt->{splitwide}) {
		if ($w == $room - 1 && $b =~ /\A\p{IsWideSpacing}/p) {
		    $a .= $opt->{lefthalf};
		    $b  = $opt->{righthalf} . ${^POSTMATCH};
		    $w++;
		}
		elsif ($w > $room) {
		    $a = $opt->{lefthalf};
		    $b = $opt->{righthalf} . $b;
		    $w--;
		}
	    }
	    if ($w > $room && $room != $width) {
		$_ = $s . $_;
		last;
	    }
	    ($folded, $_) = ($folded . $a, $b . $_);
	    $room -= $w;
	} else {
	    die "panic ($_)";
	}
    }

    ##
    ## --boundary=word
    ##
    if ($word_char_re
	and my($w2) = /\A( (?: ${word_char_re} \cH ? ) + )/x
	and my($lead, $w1) = $folded =~ m{
		\A ## avoid CSI/OSC final char making a word
		   ( (?: [^\e\x9b\x9d]* (?:${csi_re}|${osc_re})++ ) *+ .*? )
		   ( (?: ${word_char_re} \cH ? ) + )
		\z }x
    ) {
	## Break line before word only when enough space will be
	## provided for the word in the next turn.
	my $l = pwidth($w1);
	## prefix length
	my $p = $opt->{prefix} eq '' ? 0 : vwidth($opt->{prefix});
	if ($room + $l < $width - $p and $l + pwidth($w2) <= $width - $p
	    and pwidth($lead) > 0) {
	    $folded = $lead;
	    $_ = $w1 . pop_reset() . $_;
	    $room += $l;
	}
    }

    ##
    ## RUN-OUT
    ##
    if ($_ ne '' and $opt->do_runout) {
	if ($folded =~ m{ (?  (?! ${reset_re}) ${color_re}*+ )
			  (?
			    (?: ($prohibition_re{end}) (?: \cH{1,2} \g{-1})* )+
			  ) \z
			}xp
	    and ${^PREMATCH} ne '' and pwidth(${^PREMATCH}) > 0
	    and (my $w = pwidth $+{runout}) <= $opt->{runout}) {

	    $folded = ${^PREMATCH};
	    $_ = join '', ${^MATCH}, @reset, $_;
	    pop_reset() if $+{color};
	    $room += $w;
	}
    }

    $folded .= pop_reset() if @reset;

    $room += $opt->{margin};

    ##
    ## RUN-IN
    ##
    if ($opt->do_runin) {
	my @runin;
	my $m = $opt->{runin};
	while ($m > 0 and
	       m{\A (? ${color_re}*+)
	            (? $prohibition_re{head} )
		    ( \cH{1,2} \g{runin} )* # multiple strike
	            (? (?: $erase_re* $reset_re+ $erase_re* )? )
	       }xp) {
	    my $w = vwidth $+{runin};
	    last if ($m -= $w) < 0;
	    $+{color} and do { push @color_stack, $+{color} };
	    $+{reset} and do { @color_stack = () };
	    $room -= $w;
	    push @runin, ${^MATCH};
	    $_ = ${^POSTMATCH};
	}
	$folded .= join '', @runin if @runin;
    }

    if (@color_stack) {
	$folded .= SGR_RESET;
	$_ = join '', @color_stack, $_ if $_ ne '';
    }
    if (defined $osc8_link) {
	$folded .= OSC8_RESET;
	$_ = $osc8_link . $_ if $_ ne '';
    }

    if ($opt->{padding} and $room > 0) {
	my $padding = $opt->{padchar} x $room;
	if (@bg_stack) {
	    $padding = join '', @bg_stack, $padding, SGR_RESET;
	}
	$folded .= $padding;
    }

    if (length and my $p = $opt->{prefix}) {
	my $s = ref $p eq 'CODE' ? &$p : $p;
	$_ = $s . $_;
    }

    ($folded . $eol, $_, $width - $room);
}

##
## Trim off one or more *logical* characters from the beginning of a line
##
sub simple_fold {
    my $orig = shift;
    my $width = shift;
    $width <= 0 and croak "parameter error";

    my($left, $right) = $orig =~ m/^(\X{0,$width}+)(.*)/
	or croak "$width: unexpected width";

    my $w = vwidth $left;
    while ($w > $width) {
	use integer;
	my $trim = ($w - $width + 1) / 2;
	$left =~ s/\X \K ( \X{$trim} ) \z//x or last;
	$right = $1 . $right;
	$w -= vwidth $1;
    }

    ($left, $right, $w);
}

######################################################################
# EXTERNAL METHODS

sub text :lvalue {
    my $obj = shift;
    if (@_ == 0) {
	$obj->{text};
    } else {
	croak "Invalid argument" if @_ > 1;
    	$obj->{text} = shift;
	$obj;
    }
}

sub retrieve {
    my $obj = shift;
    local *_ = \$obj->{text};
    return '' if not defined $_;
    (my $folded, my $rest) = $obj->fold($_, @_);
    die "panic: retrieve: no progress in fold"
	if length $rest and $rest eq $_;
    $_ = length $rest ? $rest : undef;
    $folded;
}

sub chops {
    my $obj = shift;
    my %opt = @_;
    my $width = $opt{width} // $obj->{width};

    my @chops;

    if (ref $width eq 'ARRAY') {
	for my $w (@{$width}) {
	    if ($w == 0) {
		push @chops, '';
	    }
	    elsif ((my $chop = $obj->retrieve(width => $w)) ne '') {
		push @chops, $chop;
	    }
	    else {
		last;
	    }
	}
    }
    else {
	while ((my $chop = $obj->retrieve(width => $width)) ne '') {
	    push @chops, $chop;
	}
    }

    @chops;
}

1;

__END__