view release on metacpan or  search on metacpan

lib/App/Greple/subst.pm  view on Meta::CPAN

    &subst_search
    );
our %EXPORT_TAGS = ( );
our @EXPORT_OK   = qw();

use Carp;
use Data::Dumper;
use Text::ParseWords qw(shellwords);
use Encode;
use List::Util qw(max sum mesh);
use Getopt::EX::Colormap qw(colorize);
use Getopt::EX::LabeledParam;
use App::Greple::Common;
use App::Greple::Pattern;
use App::Greple::subst::Dict;

use File::Share qw(:all);
$ENV{GREPLE_SUBST_DICT} //= dist_dir 'App-Greple-subst';

our $debug = 0;
our $opt_subst = 0;
our @opt_subst_from;
our @opt_subst_to;
our @opt_dictfile;
our @opt_dictdata;
our $opt_printdict;
our $opt_dictname;
our $opt_check = 'outstand';
our @opt_format;
our @default_opt_format = ( '%s' );
our $opt_subst_select;
our $opt_linefold;
our $opt_ignore_space = 0;
our $opt_warn_overlap = 1;
our $opt_warn_include = 0;
our $opt_stat_style = "default";
our @opt_stat_item;
our %opt_stat_item = (
    map( { $_ => 1 } qw(match expect number ng ok) ),
    map( { $_ => 0 } qw(dict) ),
    );
our $opt_show_comment = 0;
our $opt_show_numbers = 1;
our $opt_show_dictdir = 0;

my %stat;

my $current_file;
my $ignorechar_re;
my @dicts;

sub debug {
    $debug = 1;
}

sub subst_initialize {

    state $once_called++ and return;

    if ($opt_show_dictdir) {
	say "$ENV{GREPLE_SUBST_DICT}";
	exit;
    }

    Getopt::EX::LabeledParam
	->new(HASH => \%opt_stat_item)
	->load_params(@opt_stat_item);

    @opt_format = @default_opt_format if @opt_format == 0;

    $ignorechar_re = $opt_ignore_space ? qr/\s+/ : qr/\R+/;

    my $config = { linefold  => $opt_linefold,
		   dictname  => $opt_dictname,
		   printdict => $opt_printdict };
    if (@opt_subst_from) {
	die if @opt_subst_from != @opt_subst_to;
	push @dicts, App::Greple::subst::Dict->new(
	    DATA => [ mesh \@opt_subst_from, \@opt_subst_to ],
	    CONFIG => $config,
	    );
    }
    for my $data (@opt_dictdata) {
	push @dicts, App::Greple::subst::Dict->new(
	    DATA => $data,
	    CONFIG => $config,
	    );
    }
    for my $file (@opt_dictfile) {
	if (-d $file) {
	    warn "$file is directory\n";
	    next;
	}
	push @dicts, App::Greple::subst::Dict->new(
	    FILE => $file,
	    CONFIG => $config,
	    );
    }

    if (@dicts == 0) {
	warn "Module -Msubst requires dictionary data.\n";
	main::usage();
	die;
    }
}

sub subst_begin {
    my %arg = @_;
    $current_file = delete $arg{&FILELABEL} or die;
}

use Text::VisualWidth::PP;
use Text::VisualPrintf qw(vprintf vsprintf);

sub vwidth {
    if (not defined $_[0] or length $_[0] == 0) {
	return 0;
    }
    Text::VisualWidth::PP::width $_[0];
}

my @match_list;

sub subst_show_stat {
    my %arg = @_;
    my($from_max, $to_max) = (0, 0);
    my $i = -1;
    my @show_list;
    for my $dict (@dicts) {
	my @fromto = $dict->words;
	my @show;
	for my $p (@fromto) {
	    $i++;
	    $p // die;
	    if ($p->is_comment) {
		push @show, [ $i, $p, {} ] if $opt_show_comment;
		next;
	    }
	    my($from_re, $to) = ($p->string, $p->correct // '');
	    my $hash = $match_list[$i] // {};
	    my @keys = keys %{$hash};
	    my @ng = grep { $_ ne $to } @keys;
	    my @ok = grep { $_ eq $to } @keys;
	    if    ($opt_check eq 'none'    ) { next if @keys != 0 }
	    elsif ($opt_check eq 'any'     ) { next if @keys == 0 }
	    elsif ($opt_check eq 'ok'      ) { next if @ok   == 0 }
	    elsif ($opt_check eq 'ng'      ) { next if @ng   == 0 }
	    elsif ($opt_check eq 'outstand') { next if @ng   == 0 }
	    elsif ($opt_check eq 'all')      { }
	    else { die }
	    $from_max = max $from_max, vwidth $from_re;
	    $to_max   = max $to_max  , vwidth $to;
	    push @show, [ $i, $p, $hash ];
	}
	push @show_list, [ $dict => \@show ];
    }
    if ($opt_show_numbers) {
	no warnings 'uninitialized';
	printf "HIT_PATTERN=%d/%d NG=%d, OK=%d, TOTAL=%d\n",
	    $stat{hit}, $stat{total},
	    $stat{ng}, $stat{ok}, $stat{ng} + $stat{ok};
    }
    for my $show_list (@show_list) {
	my($dict, $show) = @{$show_list};
	next if @$show == 0;
	my $dict_format = ">>> %s <<<\n";
	if ($opt_stat_item{dict}) {
	    print colorize('000/L24E', sprintf($dict_format, $dict->NAME));
	}
	for my $item (@$show) {
	    my($i, $p, $hash) = @$item;
	    if ($p->is_comment) {
		say $p->comment if $opt_show_comment;
		next;
	    }
	    my($from_re, $to) = ($p->string, $p->correct // '');
	    my @keys = keys %{$hash};
	    if ($opt_stat_style eq 'dict') {
		vprintf("%-${from_max}s // %s", $from_re // '', $to // '');
	    } else {
		my @ng = sort { $hash->{$b} <=> $hash->{$a} } grep { $_ ne $to } @keys
		    if $opt_stat_item{ng};
		my @ok = grep { $_ eq $to } @keys
		    if $opt_stat_item{ok};
		vprintf("%${from_max}s => ", $from_re // '') if $opt_stat_item{match};
		vprintf("%-${to_max}s",      $to // '')      if $opt_stat_item{expect};
		vprintf(" %4d:",             $i + 1)         if $opt_stat_item{number};
		for my $key (@ng, @ok) {
		    my $index = $key eq $to ? $i * 2 + 1 : $i * 2;
		    printf(" %s(%s)",
			   main::index_color($index, $key),
			   colorize($key eq $to ? 'DB' : 'DR', $hash->{$key})
			);
		}
	    }
	    print "\n";
	}
    }
    $_ = "";
}

use App::Greple::Regions qw(match_regions merge_regions filter_regions);

sub subst_search {
    my $text = $_;
    my %arg = @_;
    $current_file = delete $arg{&FILELABEL} or die;

    my @matched;
    my $index = -1;
    my @effective;
    my $ng = {ng=>1,        any=>1, all=>1, none=>1}->{$opt_check} ;
    my $ok = {       ok=>1, any=>1, all=>1, none=>1}->{$opt_check} ;
    my $outstand = $opt_check eq 'outstand';
    for my $dict (@dicts) {
	for my $p ($dict->words) {
	    $index++;
	    $p // next;
	    next if $p->is_comment;
	    my($from_re, $to) = ($p->string, $p->correct // '');
	    my @match = match_regions pattern => $p->regex;

	    ##
	    ## Remove all overlapped matches.
	    ##
	    my($in, $over, $out, $im, $om) = filter_regions \@match, \@matched;
	    @match = @$out;
	    for my $warn (
		[ "Include", $in,   $im, $opt_warn_include ],
		[ "Overlap", $over, $om, $opt_warn_overlap ],
		) {
		my($kind, $list, $match, $show) = @$warn;
		$show and @$list or next;