File Coverage

blib/lib/Text/ANSI/Fold.pm

Criterion	Covered	Total	%
statement	240	256	93.7
branch	114	138	82.6
condition	43	57	75.4
subroutine	37	37	100.0
pod	0	19	0.0
total	434	507	85.6

package Text::ANSI::Fold;

use v5.14;
use warnings;
use utf8;

our $VERSION = "2.20";

use Data::Dumper;
$Data::Dumper::Sortkeys = 1;
use Carp;
use List::Util qw(pairmap pairgrep);
use Scalar::Util qw(looks_like_number);
use Text::VisualWidth::PP 'vwidth';
sub pwidth { vwidth $_[0] =~ s/\X\cH{1,2}//gr }

######################################################################
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;
our $csi_re      = qr{
    # see ECMA-48 5.4 Control sequences
    (?: \e\[ | \x9b )	# csi
    [\x30-\x3f]*	# parameter bytes
    [\x20-\x2f]*	# intermediate bytes
    [\x40-\x7e]		# final byte
}x;
our $osc_re      = qr{
    # see ECMA-48 8.3.89 OSC - OPERATING SYSTEM COMMAND
    (?: \e\] | \x9d )		# osc
    [\x08-\x13\x20-\x7d]*+	# command
    (?: \e\\ | \x9c | \a )	# st: string terminator
}x;

use constant SGR_RESET => "\e[m";

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
END
}

sub IsWideAmbiguousSpacing {
    return <<"END";
+utf8::East_Asian_Width=Wide
+utf8::East_Asian_Width=FullWidth
+utf8::East_Asian_Width=Ambiguous
-utf8::Nonspacing_Mark
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}" ],				    # ▁
    bar    => [ "\N{BOX DRAWINGS HEAVY RIGHT}",				    # ╺
		"\N{BOX DRAWINGS LIGHT HORIZONTAL}" ],			    # ─
    dash   => [ "\N{BOX DRAWINGS HEAVY RIGHT}",				    # ╺
		"\N{BOX DRAWINGS LIGHT DOUBLE DASH HORIZONTAL}" ],	    # ╌

    dot          => '.',
    space        => ' ',
    emspace      => "\N{EM SPACE}",					    #
    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}",				    # 𒋰

    );

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   => {},
    );

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;
sub put_reset { @reset = shift };
sub pop_reset {
    @reset ? do { @color_stack = (); pop @reset } : '';
}
sub vlength { length $_[0] =~ s/.\cH//gr }

use constant MAX_INT => ~0 >> 1;

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

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

    my $width = $opt->{width};
    croak "invalid width" if not looks_like_number $width;
    $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} // ''};

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

    my $folded = '';
    my $eol = '';
    my $room = $width;
    @bg_stack = @color_stack = @reset = ();
    my $yield_re = $opt->{expand} ? qr/[^\e\n\f\r\t]/ : qr/[^\e\n\f\r]/;

  FOLD:
    while (length) {

	# newline
	if (s/\A(\r*\n)//) {
	    $eol = $1;
	    last;
	}
	# formfeed / carriage return
	if (s/\A([\f\r]+)//) {
	    last if length == 0;
	    $folded .= $1;
	    $room = $width;
	    next;
	}
	# ECMA-48 OPERATING SYSTEM COMMAND
	if (s/\A($osc_re)//) {
	    $folded .= $1 unless $obj->{discard}->{OSC};
	    next;
	}
	# erase line (assume 0)
	if (s/\A($erase_re)//) {
	    $folded .= $1 unless $obj->{discard}->{EL};
	    @bg_stack = @color_stack;
	    next;
	}
	# reset
	if (s/\A($reset_re+($erase_re*))//) {
	    put_reset($1);
	    @bg_stack = () if $2;
	    next;
	}

	last if $room < 1;
	last if $room != $width and &_startWideSpacing and $room < 2;

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

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

	# 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 (s/\A(?:\X\cH+)++(?\X|\z)//p) {
	    my $w = vwidth($+{c});
	    if ($w > $room) {
		if ($folded eq '') {
		    $folded .= ${^MATCH};
		    $room -= $w;
		} else {
		    $_ = ${^MATCH} . $_;
		}
		last FOLD;
	    }
	    $folded .= ${^MATCH};
	    $room -= $w;
	    $bs++;
	    last if $room < 1;
	}
	next if $bs;

	if (s/\A(\e*(?:${yield_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 ($w > $room and $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 final char does not make a word
		   ( (?: [^\e]* ${csi_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 = vlength($w1);
	## prefix length
	my $p = $opt->{prefix} eq '' ? 0 : vwidth($opt->{prefix});
	if ($room + $l < $width - $p and $l + vlength($w2) <= $width - $p) {
	    $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 (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 ($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 top.
##
sub simple_fold {
    my $orig = shift;
    my $width = shift;
    $width <= 0 and croak "parameter error";

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

    my $w = vwidth($left);
    while ($w > $width) {
	my $trim = do {
	    # use POSIX qw(ceil);
	    # ceil(($w - $width) / 2) || 1;
	    int(($w - $width) / 2 + 0.5) || 1;
	};
	$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, $_) = $obj->fold($_, @_);
    $_ = undef if length == 0;
    $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__