view release on metacpan or  search on metacpan

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

    close STDERR;
    exit 0;
}

sub set {
    my %opt = @_;
    for my $io (qw(PREFORK STDIN STDOUT STDERR)) {
	my $filter = delete $opt{$io} // next;
	if ($filter =~ s/^&//) {
	    if ($filter !~ /::/) {
		$filter = join '::', __PACKAGE__, $filter;
	    }
	    use Getopt::EX::Func qw(parse_func);
	    my $func = parse_func($filter);
	    io_filter { $func->call() } $io => 1;
	}
	else {
	    io_filter { exec $filter or die "exec: $!\n" } $io => 1;
	}
    }
    %opt and die "Unknown parameter: " . Dumper \%opt;
    ();
}

=item B<set>(I<io>=I<command>)

=item B<set>(I<io>=&I<function>)

Primitive function to prepare input/output filter.  All options are
implemented by this function.  Takes C<STDIN>, C<STDOUT>, C<STDERR>,
C<PREFORK> as an I<io> name and I<command> or &I<function> as a vaule.

    mode function
    option --if   &set(STDIN=$<shift>)
    option --isub &set(STDIN=&$<shift>)

=cut

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

sub unctrl {
    while (<>) {
	s/([\000-\010\013-\037\177])/'^' . pack('c', ord($1)|0100)/ge;
	print;
    }
}

=item B<unctrl>()

Visualize control characters.

=cut

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

my %control  = (
    nul  => [ 's', "\000", "\x{2400}" ], # ␀ SYMBOL FOR NULL
    soh  => [ 's', "\001", "\x{2401}" ], # ␁ SYMBOL FOR START OF HEADING
    stx  => [ 's', "\002", "\x{2402}" ], # ␂ SYMBOL FOR START OF TEXT
    etx  => [ 's', "\003", "\x{2403}" ], # ␃ SYMBOL FOR END OF TEXT
    eot  => [ 's', "\004", "\x{2404}" ], # ␄ SYMBOL FOR END OF TRANSMISSION
    enq  => [ 's', "\005", "\x{2405}" ], # ␅ SYMBOL FOR ENQUIRY
    ack  => [ 's', "\006", "\x{2406}" ], # ␆ SYMBOL FOR ACKNOWLEDGE
    bel  => [ 's', "\007", "\x{2407}" ], # ␇ SYMBOL FOR BELL
    bs   => [ 's', "\010", "\x{2408}" ], # ␈ SYMBOL FOR BACKSPACE
    ht   => [ 's', "\011", "\x{2409}" ], # ␉ SYMBOL FOR HORIZONTAL TABULATION
    nl   => [  '', "\012", "\x{240A}" ], # ␊ SYMBOL FOR LINE FEED
    vt   => [ 's', "\013", "\x{240B}" ], # ␋ SYMBOL FOR VERTICAL TABULATION
    np   => [ 's', "\014", "\x{240C}" ], # ␌ SYMBOL FOR FORM FEED
    cr   => [ 's', "\015", "\x{240D}" ], # ␍ SYMBOL FOR CARRIAGE RETURN
    so   => [ 's', "\016", "\x{240E}" ], # ␎ SYMBOL FOR SHIFT OUT
    si   => [ 's', "\017", "\x{240F}" ], # ␏ SYMBOL FOR SHIFT IN
    dle  => [ 's', "\020", "\x{2410}" ], # ␐ SYMBOL FOR DATA LINK ESCAPE
    dc1  => [ 's', "\021", "\x{2411}" ], # ␑ SYMBOL FOR DEVICE CONTROL ONE
    dc2  => [ 's', "\022", "\x{2412}" ], # ␒ SYMBOL FOR DEVICE CONTROL TWO
    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($_);