File Coverage

blib/lib/Text/Conceal.pm

Criterion	Covered	Total	%
statement	103	117	88.0
branch	35	52	67.3
condition	9	14	64.2
subroutine	17	20	85.0
pod	3	6	50.0
total	167	209	79.9

package Text::Conceal;

our $VERSION = '1.05';

use v5.14;
use warnings;
use utf8;
use Carp;
use Data::Dumper;
{
    no warnings 'redefine', 'once';
    *Data::Dumper::qquote = sub { qq["${\(shift)}"] };
    $Data::Dumper::Useperl = 1;
    $Data::Dumper::Sortkey = 1;
}

my %char_range = (
    STRAIGHT => [ [0x01=>0x07], [0x10=>0x1f], [0x21=>0x7e], [0x81=>0xfe] ],
    MODERATE => [ [0x21=>0x7e], [0x01=>0x07], [0x10=>0x1f], [0x81=>0xfe] ],
    VISIBLE  => [ [0x21=>0x7e] ],
    );

my %default = (
    test      => undef,
    length    => sub { length $_[0] },
    match     => qr/.+/s,
    except    => '',
    max       => 0,
    visible   => 0,
    ordered   => 1,
    duplicate => 0,
    zerowidth => undef,
);

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

sub configure {
    my $obj = shift;
    while (my($k, $v) = splice @_, 0, 2) {
	if (not exists $default{$k}) {
	    croak "$k: invalid parameter";
	}
	if ($k eq 'test') {
	    $obj->{$k} = do {
		if    (not $v)             { sub { 1 } }
		elsif (ref $v eq 'Regexp') { sub { $_[0] =~ $v } }
		elsif (ref $v eq 'CODE')   { $v }
		else                       { sub { 1 } }
	    };
	} else {
	    $k eq 'length' and ( ref $v eq 'CODE' or die );
	    $obj->{$k} = $v;
	}
    }
    $obj;
}

sub encode {
    my $obj = shift;
    $obj->{replace} = [];
    my $conceal = $obj->concealer(grep defined, $obj->{except}, @_)
	or return @_;
    my $match = $obj->{match} or die;
    my $test = $obj->{test};
    for my $arg (grep defined, @_) {
	$test->($arg) or next if $test;
	$arg =~ s{$match}{
	    if (my($replace, $regex, $len) = $conceal->(${^MATCH})) {
		push @{$obj->{replace}}, [ $regex, ${^MATCH}, $len ];
		$replace;
	    } else {
		${^MATCH};
	    }
	}pge;
    }
    @_;
}

sub decode {
    my $obj = shift;
    my @replace = @{$obj->{replace}} or return @_;
  ARGS:
    for (@_) {
	# do not use "each @replace" here
	for my $i (keys @replace) {
	    my($regex, $orig, $len) = @{$replace[$i]};
	    $regex // next;
	    if (s/$regex/_replace(${^MATCH}, $orig, $len)/pe) {
		if ($obj->{duplicate}) {
		    ;
		} elsif ($obj->{ordered}) {
		    splice @replace, 0, $i + 1;
		} else {
		    splice @replace, $i, 1;
		}
		redo ARGS;
	    }
	}
    }
    @_;
}

sub _replace {
    my($matched, $orig, $len) = @_;
    my $width = length $matched;
    if ($width == $len) {
	$orig;
    } else {
	_trim($orig, $width);
    }
}

sub _trim {
    my($str, $width) = @_;
    use Text::ANSI::Fold;
    state $f = Text::ANSI::Fold->new(padding => 1);
    my($folded, $rest, $w) = $f->fold($str, width => $width);
    if ($w <= $width) {
	$folded;
    } elsif ($width == 1) {
	' '; # wide char not fit to single column
    } else {
	die "Panic"; # should never reach here...
    }
}

sub concealer {
    my $obj = shift;
    my $max = $obj->{max};
    local $_ = join '', @_;
    my @a;
    my @range = do {
	map { $_->[0] .. $_->[1] }
	@{ $obj->{range} //= $obj->char_range };
    };
    for my $i (@range) {
	my $c = pack "C", $i;
	push @a, $c if index($_, $c) < 0;
	last if $max && @a > $max;
    }
    return if @a < 2;
    my $lead = do { local $" = ''; qr/[^\Q@a\E]*+/ };
    my $b = shift @a;
    return sub {
	my $len = $obj->{length}->($_[0] =~ s/\X\cH+//gr);
	if ($len == 0) {
	    if (defined(my $zerowidth = $obj->{zerowidth})) {
		return($zerowidth, undef, $len);
	    } else {
		return;
	    }
	}
	my $a = $a[ (state $n)++ % @a ];
	my $bl = $len - 1;
	( $a . ($b x $bl), qr/\A${lead}\K\Q$a$b\E{0,$bl}(?!\Q$b\E)/, $len );
    };
}

sub char_range {
    my $obj = shift;
    my $v = $obj->{visible} // 0;
    if    ($v == 0) { $char_range{STRAIGHT} }
    elsif ($v == 1) { $char_range{MODERATE} }
    elsif ($v == 2) { $char_range{VISIBLE}  }
    else            { die }
}

1;

__END__