view release on metacpan or  search on metacpan

lib/App/optex/util/filter.pm  view on Meta::CPAN

    dc3  => [ 's', "\023", "\x{2413}" ], # ␓ SYMBOL FOR DEVICE CONTROL THREE
    dc4  => [ 's', "\024", "\x{2414}" ], # ␔ SYMBOL FOR DEVICE CONTROL FOUR
    nak  => [ 's', "\025", "\x{2415}" ], # ␕ SYMBOL FOR NEGATIVE ACKNOWLEDGE
    syn  => [ 's', "\026", "\x{2416}" ], # ␖ SYMBOL FOR SYNCHRONOUS IDLE
    etb  => [ 's', "\027", "\x{2417}" ], # ␗ SYMBOL FOR END OF TRANSMISSION BLOCK
    can  => [ 's', "\030", "\x{2418}" ], # ␘ SYMBOL FOR CANCEL
    em   => [ 's', "\031", "\x{2419}" ], # ␙ SYMBOL FOR END OF MEDIUM
    sub  => [ 's', "\032", "\x{241A}" ], # ␚ SYMBOL FOR SUBSTITUTE
    esc  => [  '', "\033", "\x{241B}" ], # ␛ SYMBOL FOR ESCAPE
    fs   => [ 's', "\034", "\x{241C}" ], # ␜ SYMBOL FOR FILE SEPARATOR
    gs   => [ 's', "\035", "\x{241D}" ], # ␝ SYMBOL FOR GROUP SEPARATOR
    rs   => [ 's', "\036", "\x{241E}" ], # ␞ SYMBOL FOR RECORD SEPARATOR
    us   => [ 's', "\037", "\x{241F}" ], # ␟ SYMBOL FOR UNIT SEPARATOR
    sp   => [ 's', "\040", "\x{2420}" ], # ␠ SYMBOL FOR SPACE
    del  => [ 's', "\177", "\x{2421}" ], # ␡ SYMBOL FOR DELETE
    nbsp => [ 's', "\240", "\x{2423}" ], # ␣ OPEN BOX
);

use List::Util qw(pairmap);
my %symbol = pairmap { $b->[1] => $b->[2] } %control;
my %char   = pairmap { $a => $b->[1] } %control;

my $keep_after = qr/[\n]/;

use Text::ANSI::Tabs qw(ansi_expand);

sub visible {
    my %opt = @_;
    my %flag = pairmap { $a => $b->[0] } %control;
    lock_keys %flag;
    if (defined(my $all = delete $opt{all})) {
	$flag{$_} = $all for keys %flag;
    }
    my($s_char, $c_char) = ('', '');
    for my $name (qw(tabstyle tabstop)) {
	if (exists $opt{$name} and my $value = delete $opt{$name}) {
	    Text::ANSI::Tabs->configure($name => $value);
	}
    }
    %flag = (%flag, %opt);
    for my $name (keys %flag) {
	if    ($flag{$name} eq 'c') { $c_char .= $char{$name} }
	elsif ($flag{$name})        { $s_char .= $char{$name} }
    }
    while (<>) {
	$_ = ansi_expand($_);
	s{(?=(${keep_after}?))([$s_char]|(?#bug?)(?!))}{$symbol{$2}$1}g
	    if $s_char ne '';
	s{(?=(${keep_after}?))([$c_char]|(?#bug?)(?!))}{
	    '^'.pack('c',ord($2)+64).$1
	}ge if $c_char ne '';
	print;
    }
}

=item B<visible>(I<name>=I<flag>)

Make control and space characters visible.

By default, ESCAPE and NEWLINE is not touched.  Other control
characters and space are shown in unicode symbol.  Tab character and
following space is visualized in unicode mark.

When newline character is visualized, it is not deleted and shown with
visible representation.

=over 7

=item I<name>

Name is C<tabstop>, C<tabstyle>, C<all>, or one of these:

    000 nul  001 soh  002 stx  003 etx  004 eot  005 enq  006 ack  007 bel
    010 bs   011 ht   012 nl   013 vt   014 np   015 cr   016 so   017 si
    020 dle  021 dc1  022 dc2  023 dc3  024 dc4  025 nak  026 syn  027 etb
    030 can  031 em   032 sub  033 esc  034 fs   035 gs   036 rs   037 us
    040 sp
    240 nbsp

If the name is C<all>, the value is set for all characters.
Default is equivalent to:

    visible(tabstyle=bar,all=s,esc=0,nl=0)

Tab width can be set by C<tabstop>.  As for C<tabstyle>, use anything
defined in L<Text::ANSI::Fold>.

=item I<flag>

If the flag is empty or 0, the character is displayed as is.  If flag
is C<c>, it is shown in C<^c> format.  Otherwise shown in unicode
symbol.

=back

=cut

######################################################################

sub rev_line {
    print reverse <STDIN>;
}

=item B<rev_line>()

Reverse output.

=cut

######################################################################

sub rev_char {
    while (<>) {
	my $lb = s/(\R)\z// ? $1 : '';
	print reverse(/\X/g), $lb;
    }
}

=item B<rev_char>()

Reverse characters in each line.

=cut

######################################################################

use List::Util qw(shuffle);

sub shuffle_line {
    print shuffle <>;
}

=item B<shuffle_line>()

Shuffle lines.

=cut

######################################################################

use Getopt::EX::Colormap qw(colorize);

sub io_color {
    my %opt = @_;
    for my $io (qw(STDIN STDOUT STDERR)) {
	my $color = $opt{$io} // next;
	io_filter {
	    while (<>) {
		print colorize($color, $_);
	    }
	} $io => 1;