File Coverage

blib/lib/App/ansiecho.pm

Criterion	Covered	Total	%
statement	140	143	97.9
branch	52	58	89.6
condition	24	31	77.4
subroutine	22	23	95.6
pod	0	4	0.0
total	238	259	91.8

package App::ansiecho;

our $VERSION = "1.10";

use v5.14;
use warnings;

use utf8;
use Encode;
use Data::Dumper;
{
    no warnings 'redefine';
    *Data::Dumper::qquote = sub { qq["${\(shift)}"] };
    $Data::Dumper::Useperl = 1;
}
use open IO => 'utf8', ':std';
use Pod::Usage;

use App::ansiecho::Util qw(decode_argv unescape);
use Getopt::EX v1.24.1;
use Text::ANSI::Printf 2.03 qw(ansi_sprintf);
$Text::ANSI::Printf::REORDER = 1;
use List::Util qw(max);

use Getopt::EX::Hashed; {
    Getopt::EX::Hashed->configure(DEFAULT => [ is => 'rw' ]);
    has debug      => "      " ;
    has n          => "      " , action => sub { $_->terminate = '' };
    has join       => " j    " , action => sub { $_->separate = '' };
    has escape     => " e !  " , default => 1;
    has rgb24      => "   !  " ;
    has separate   => "   =s " , default => " ";
    has help       => " h    " ;
    has version    => " v    " ;

    has '+separate' => sub {
	my($name, $arg) = map "$_", @_;
	$_->$name = unescape($arg);
    };

    has '+rgb24' => sub {
	$Term::ANSIColor::Concise::RGB24 = !!$_[1];
    };

    has '+help' => sub {
	pod2usage
	    -verbose  => 99,
	    -sections => [ qw(SYNOPSIS VERSION) ];
    };

    has '+version' => sub {
	say "Version: $VERSION";
	exit;
    };

    has terminate  => default => "\n";
    has params     => default => [];

} no Getopt::EX::Hashed;

sub run {
    my $app = shift;
    $app->options(@_);
    print $app->retrieve, $app->terminate;
}

sub options {
    my $app = shift;
    my @argv = decode_argv @_;
    use Getopt::EX::Long qw(GetOptionsFromArray Configure ExConfigure);
    ExConfigure BASECLASS => [ __PACKAGE__, "Getopt::EX" ];
    Configure qw(bundling no_getopt_compat pass_through);
    $app->getopt(\@argv) || pod2usage();
    $app->params(\@argv);
    $app;
}

use Term::ANSIColor::Concise qw(ansi_color ansi_code);

sub uniname {
    local $_ = @_ ? shift : $_;
    my @names = map { /^[\da-f]{1,6}$/i ? "\\N{U+$_}" : "\\N{$_}" } /[-+_\w ]+/g;
    unescape join '', @names;
}

sub retrieve {
    my $app = shift;
    my $count = shift // 0;
    my $in = $app->params;
    my(@style, @effect);

    my @out;
    my @pending;
    my $charge = sub { push @pending, @_ };
    my $discharge = sub {
	return if @pending == 0 and @_ == 0;
	if ($count == 0 and @out > 0 and $app->separate ne '') {
	    push @out, $app->separate;
	}
	push @out, join '', splice(@pending), @_;
    };

    while (@$in) {
	my $arg = shift @$in;

	# -x : set separator
	if ($arg =~ /^-x(?u)?$/) {
	    my $uni = %+;
	    my $sep = $app->retrieve(1) // die "Not enough argument.\n";
	    $app->separate = $uni ? uniname($sep) : $sep;
	    next;
	}
	# -S
	if ($arg =~ /^-S$/) {
	    unshift @style, [ \&ansi_code ];
	    next;
	}
	# -c, -C
	if ($arg =~ /^-([cC])(.+)?$/) {
	    my $target = $1 eq 'c' ? \@effect : \@style;
	    my $color = defined $2 ? unescape($2) : $app->retrieve(1);
	    unshift @$target, [ \&ansi_color, $color ];
	    next;
	}
	# -F
	if ($arg =~ /^-(F)(.+)?$/) {
	    my $format = defined $2 ? unescape($2) : $app->retrieve(1);
	    unshift @style, [ \&ansi_sprintf, $format ];
	    next;
	}
	# -U
	if ($arg =~ /^-(U)$/) {
	    unshift @style, [ \&uniname ];
	    next;
	}
	# -E
	if ($arg =~ /^-E$/) {
	    @style = ();
	    next;
	}

	#
	# -s, -i, -a : ANSI sequence
	#
	if ($arg =~ /^-([sia])(.+)?$/) {
	    my $opt = $1;
	    my $text = $2 // shift(@$in) // die "Not enough argument.\n";
	    my $code = ansi_code($text);
	    if ($opt eq 's') {
		$arg = $code;
	    } else {
		if (@out == 0 or $opt eq 'i') {
		    $charge->($code);
		} else {
		    $out[-1] .= $code;
		}
		next;
	    }
	}
	#
	# -f : format
	#
	elsif ($arg =~ /^-f(.+)?$/) {
	    my($format) = defined $1 ? unescape($1) : $app->retrieve(1);
	    state $param_re = do {
		my $P = qr/\d+\$/;
		my $W = qr/\d+|\*$P?/;
		qr{ %% |
		    (? % $P?) [-+#0\ ]*+
		    (?: (? \* $P?+ )? v )?+
		    (?: (?$W) (?:\.(?$W))?+ | \.(?$W) )?+
		    (?:[hjlqLltz]|[csduoxefgXEGbBpnaAiDUOF])
		}x;
	    };
	    my($pos, $n) = (0, 0);
	    while ($format =~ /$param_re/g) {
		$+{I} // next;
		for ($+{I}, grep { defined and /\*/ } @+{qw(I V A B C)}) {
		    if (/(\d+)\$/) {
			$pos = max($pos, $1);
		    } else {
			$n++;
		    }
		}
	    }
	    $n = max($pos, $n);
	    $arg = ansi_sprintf($format, $app->retrieve($n));
	}
	#
	# -u : Unicode Name
	#
	if ($arg =~ /^-u(.+)?$/) {
	    my $opt = $1;
	    my $name = $2 // shift(@$in) // die "Not enough argument.\n";
	    $arg = uniname($name);
	}
	#
	# normal string argument
	#
	else {
	    if ($app->escape) {
		$arg = unescape($arg);
	    }
	}

	#
	# apply @effect and @style
	#
	for (splice(@effect), @style) {
	    my($func, @opts) = @$_;
	    $arg = $func->(@opts, $arg);
	}

	$discharge->($arg);

	if ($count) {
	    my $out = @out + !!@pending;
	    die "Unexpected behavior.\n" if $out > $count;
	    last if $out == $count;
	}
    }
    $discharge->();
    die "Not enough argument.\n" if $count and @out < $count;
    wantarray ? @out : $out[0];
}

1;

__END__