File Coverage

blib/script/greple

Criterion	Covered	Total	%
statement	505	708	71.3
branch	203	400	50.7
condition	63	152	41.4
subroutine	66	91	72.5
pod			n/a
total	837	1351	61.9

#!/usr/bin/env perl
##
## greple: extensible grep with lexical expression and region handling
##
## Since Mar 29 1991
##

use v5.24;
use warnings;

use File::stat;
use IO::Handle;
use Pod::Usage;
use Text::ParseWords qw(shellwords);
use List::Util qw(min max first sum uniq shuffle notall pairs pairmap);
use Hash::Util qw(lock_keys);
use Cwd qw(getcwd abs_path);
use Carp;

use utf8;
use Encode;
use Encode::Guess;
use open IO => ':utf8', ':std';

use Data::Dumper;
{
    no warnings 'redefine';
    *Data::Dumper::qquote = sub { qq["${\(shift)}"] };
    $Data::Dumper::Useperl = 1;
}

##
## Setup greple/lib to be a module directory if exists.
##
BEGIN {
    if (my $lib = abs_path($0) =~ s{/(?:script/|bin/)?\w+$}{/lib}r) {
	unshift @INC, $lib if -d "$lib/App/Greple";
    }
}

use Getopt::EX::Loader;
use Getopt::EX::Func qw(parse_func callable);

use App::Greple;
use App::Greple::Common;
use App::Greple::Util qw(shellquote);
use App::Greple::Grep;
use App::Greple::Regions;
use App::Greple::Pattern;
use App::Greple::Pattern::Holder;
use App::Greple::Filter;

my $version = $App::Greple::VERSION;

=encoding utf8

=head1 NAME


greple - extensible grep with lexical expression and region control


=head1 VERSION


Version 10.04


=head1 SYNOPSIS


B [B<-M>I] [ B<-options> ] pattern [ file... ]

  PATTERN
    pattern              'and +must -not ?optional &function'
    -x, --le   pattern   lexical expression (same as bare pattern)
    -e, --and  pattern   pattern match across line boundary
    -r, --must pattern   pattern cannot be compromised
    -t, --may  pattern   pattern may exist
    -v, --not  pattern   pattern not to be matched
    -E, --re   pattern   regular expression
        --fe   pattern   fixed expression
    -f, --file file      file contains search pattern
    --select index       select indexed pattern from -f file
  MATCH
    -i, --ignore-case    ignore case
    -G, --capture-group  match capture groups rather than the whole pattern
    -S, --stretch        stretch the matched area to the enclosing block
    --need=[+-]n         required positive match count
    --allow=[+-]n        acceptable negative match count
    --matchcount=n[,m]   required match count for each block
  STYLE
    -l                   list filename only
    -c                   print count of matched block only
    -n                   print line number
    -b                   print block number
    -H, -h               do or do not display filenames
    -o                   print only the matching part
    --all                print entire data
    -F, --filter         use as a filter (implies --all --need=0 --exit=0)
    -m, --max=n[,m]      max count of blocks to be shown
    -A,-B,-C [n]         after/before/both match context
    --join               remove newline in the matched part
    --joinby=string      replace newline in the matched text with a string
    --nonewline          do not add newline character at the end of block
    --filestyle=style    how filenames are printed (once, separate, line)
    --linestyle=style    how line numbers are printed (separate, line)
    --blockstyle=style   how block numbers are printed (separate, line)
    --separate           set filestyle, linestyle, blockstyle "separate"
    --format LABEL=...   define the format for line number and file name
    --frame-top          top frame line
    --frame-middle       middle frame line
    --frame-bottom       bottom frame line
  FILE
    --glob=glob          glob target files
    --chdir=dir          change directory before search
    --readlist           get filenames from stdin
  COLOR
    --color=when         use terminal colors (auto, always, never)
    --nocolor            same as --color=never
    --colormap=color     R, G, B, C, M, Y, etc.
    --colorsub=...       shortcut for --colormap="sub{...}"
    --colorful           use default multiple colors
    --colorindex=flags   color index method: Ascend/Descend/Block/Random/Unique/Group/GP
    --random             use a random color each time (--colorindex=R)
    --uniqcolor          use a different color for each unique string (--colorindex=U)
    --uniqsub=func       preprocess function to check uniqueness
    --ansicolor=s        ANSI color 16, 256 or 24bit
    --[no]256            same as --ansicolor 256 or 16
    --regioncolor        use different color for inside and outside regions
    --face               enable or disable visual effects
  BLOCK
    -p, --paragraph      enable paragraph mode
    --border=pattern     specify a border pattern
    --block=pattern      specify a block of records
    --blockend=s         block-end mark (Default: "--")
    --join-blocks        join consecutive blocks that are back-to-back
  REGION
    --inside=pattern     select matches inside of pattern
    --outside=pattern    select matches outside of pattern
    --include=pattern    limit matches to the area
    --exclude=pattern    limit matches to outside of the area
    --strict             enable strict mode for --inside/outside --block
  CHARACTER CODE
    --icode=name         input file encoding
    --ocode=name         output file encoding
  FILTER
    --if,--of=filter     input/output filter command
    --pf=filter          post-process filter command
    --noif               disable the default input filter
  RUNTIME FUNCTION
    --begin=func         call a function before starting the search
    --end=func           call a function after completing the search
    --prologue=func      call a function before executing the command
    --epilogue=func      call a function after executing the command
    --postgrep=func      call a function after each grep operation
    --callback=func      callback function for each matched string
  OTHER
    --usage[=expand]     show this help message
    --version            show version
    --exit=n             set the command exit status
    --norc               skip reading startup file
    --man                display the manual page for the command or module
    --show               display the module file contents
    --path               display the path to the  module file
    --error=action       action to take after a read error occurs
    --warn=type          runtime error handling type
    --alert [name=#]     set alert parameters (size/time)
    -d flags             display info (f:file d:dir c:color m:misc s:stat)

=cut

my @baseclass = qw( App::Greple Getopt::EX );
my $rcloader = Getopt::EX::Loader
    ->new(BASECLASS => \@baseclass);

my @optargs;
my %optargs;

sub newopt {
    push @optargs, pairmap {
	local $_ = $a;
	s/\s+//g;
	s/^(?=\w+-)([-\w]+)/$1 =~ tr[-][_]r . "|$1"/e; # "a-b" -> "a_b|a-b"
	/^(\w+)/ and $optargs{$1} = $b if ref $b ne 'CODE';
	$_ => $b;
    } @_;
}

sub opt :lvalue {
    my $name = shift;
    my $var = $optargs{$name} or die "$name: invalid option name\n";
    if (ref $var eq 'SCALAR') {
	return $$var;
    } elsif (ref $var eq 'HASH' and @_ == 1) {
	return $var->{+shift};
    } else {
	return $var;
    }
}

my @opt_pattern;
sub opt_pattern {
    push @opt_pattern, [ map "$_", @_ ];
    $opt_pattern[-1];
}

my @opt_colormap;
sub opt_colormap { push @opt_colormap, $_[1] }
sub opt_colorsub { push @opt_colormap, "sub{ $_[1] }" }

my %opt_format = (LINE => '%d:', FILE => '%s:', BLOCK => '%s:');
my %opt_alert  = (size => 512 * 1024, time => 2);
my %opt_warn   = (read => 0, skip => 1, retry => 0, begin => 0);

newopt

    ##
    ## PATTERN
    ##
    ' and    |e =s ' => \&opt_pattern ,
    ' must   |r =s ' => \&opt_pattern ,
    ' may    |t =s ' => \&opt_pattern ,
    ' not    |v =s ' => \&opt_pattern ,
    ' le     |x =s ' => \&opt_pattern ,
    ' re     |E =s ' => \&opt_pattern ,
    ' fe        =s ' => \&opt_pattern ,
    ' file   |f =s ' => \ my @opt_f ,
    ' select    =s ' => \ my $opt_select ,

    ##
    ## MATCH
    ##
    ' ignore-case        |i  !  ' => \ my $opt_i ,
    ' need                   =s ' => \ my @opt_need ,
    ' allow                  =s ' => \ my @opt_allow ,
    ' matchcount         |mc =s ' => \ my $opt_matchcount ,
    ' capture-group      |G  !  ' => \ my $opt_capture_group ,
    ' stretch            |S  !  ' => \ my $opt_stretch ,

    ##
    ## STYLE
    ##
    ' files-with-matches |l     ' => \ my $opt_l ,
    ' count              |c     ' => \ my $opt_c ,
    ' line-number        |n  !  ' => \ my $opt_n ,
    ' block-number       |b  !  ' => \ my $opt_b ,
    ' filename           |H     ' => \ my $opt_H ,
    ' no-filename        |h     ' => \ my $opt_h ,
    ' only-matching      |o  !  ' => \ my $opt_o ,
    ' all                    !  ' => \ my $opt_all ,
    ' filter             |F  !  ' => \ my $opt_filter ,
    ' max-count          |m  =s ' => \ my $opt_m ,
    ' after-context      |A  :2 ' => \(my $opt_A = 0) ,
    ' before-context     |B  :2 ' => \(my $opt_B = 0) ,
    ' context            |C  :2 ' => \(my $opt_C = 0) ,
    ' join                   !  ' => \ my $opt_join ,
    ' joinby                 =s ' => \(my $opt_joinby = "") ,
    ' newline                !  ' => \(my $opt_newline = 1) ,
    ' filestyle          |fs =s ' => \(my $opt_filestyle = 'line') ,
    ' linestyle          |ls =s ' => \(my $opt_linestyle = 'line') ,
    ' blockstyle         |bs =s ' => \(my $opt_blockstyle = 'line') ,
    ' separate ' => sub {
	opt('filestyle') = opt('linestyle') = opt('blockstyle') = $_[0];
    },
    ' format                 =s ' => \    %opt_format ,
    ' frame-top              :s ' => \(my $opt_frame_top    = '') ,
    ' frame-middle           :s ' => \(my $opt_frame_middle = '') ,
    ' frame-bottom           :s ' => \(my $opt_frame_bottom = '') ,

    ##
    ## FILE
    ##
    ' glob                   =s ' => \ my @opt_glob ,
    ' chdir                  =s ' => \ my @opt_chdir ,
    ' readlist               !  ' => \ my $opt_readlist ,

    ##
    ## COLOR
    ##
    ' color                  =s ' => \(my $opt_color = 'auto') ,
    ' colormap           |cm =s ' => \&opt_colormap ,
    ' colorsub           |cs =s ' => \&opt_colorsub ,
    ' colorful               !  ' => \(my $opt_colorful = 1) ,
    ' colorindex         |ci =s ' => \(my $opt_colorindex = '') ,
    ' ansicolor              =s ' => \(my $opt_ansicolor = '256') ,
    ' regioncolor        |rc !  ' => \ my $opt_regioncolor ,
    ' uniqsub            |us =s ' => \ my @opt_uniqsub ,
    ' face                   =s ' => \ my @opt_face ,
    ' nocolor | no-color ' => sub {
	opt('color') = 'never';
    },
    ' 256! ' => sub {
	opt('ansicolor') = $_[1] ? '256' : '16';
    },
    ' random! ' => sub {
	if ($_[1]) { opt('colorindex') .= 'R' }
	else       { opt('colorindex') =~ s/R//gi }
    },
    ' uniqcolor |uc ' => sub {
	opt('colorindex') = 'U';
    },

    ##
    ## BLOCK
    ##
    ' paragraph          |p  !  ' => \ my $opt_p ,
    ' border                 =s ' => \ my $opt_border ,
    ' block                  =s ' => \ my @opt_block ,
    ' blockend               :s ' => \(my $opt_blockend) ,
    ' join-blocks            !  ' => \(my $opt_join_blocks = 0) ,

    ##
    ## REGION
    ##
    ' inside                 =s ' => \ my @opt_inside ,
    ' outside                =s ' => \ my @opt_outside ,
    ' include                =s ' => \ my @opt_include ,
    ' exclude                =s ' => \ my @opt_exclude ,
    ' strict                 !  ' => \(my $opt_strict = 0) ,

    ##
    ## CHARACTER CODE
    ##
    ' icode                  =s ' => \ my @opt_icode ,
    ' ocode                  =s ' => \ my $opt_ocode ,

    ##
    ## FILTER
    ##
    ' if                     =s ' => \ my @opt_if ,
    ' of                     =s ' => \ my @opt_of ,
    ' pf                     =s ' => \ my @opt_pf ,
    ' noif                      ' => \ my $opt_noif ,

    ##
    ## RUNTIME FUNCTION
    ##
    ' print                  =s ' => \ my @opt_print ,
    ' continue               !  ' => \ my $opt_continue ,
    ' callback               =s ' => \ my @opt_callback ,
    ' begin                  =s ' => \ my @opt_begin ,
    ' end                    =s ' => \ my @opt_end ,
    ' prologue               =s ' => \ my @opt_prologue ,
    ' epilogue               =s ' => \ my @opt_epilogue ,
    ' postgrep               =s ' => \ my @opt_postgrep ,

    ##
    ## OTHERS
    ##
    ' usage                  :s ' => \ my $opt_usage ,
    ' version                   ' => \ my $opt_version ,
    ' exit                   =i ' => \ my $opt_exit ,
    # norc
    ' man  | doc                ' => \ my $opt_man ,
    ' show | less               ' => \ my $opt_show ,
    ' path                      ' => \ my $opt_path ,
    ' error                  =s ' => \(my $opt_error = 'skip') ,
    ' alert                  =i ' => \    %opt_alert ,
    ' debug              |d  =s ' => \ my @opt_d ,
    'warn|w:1%' => sub {
	map { $opt_warn{$_} = $_[2] }
	map { $_ eq 'all' ? keys %opt_warn : $_ }
	$_[1] =~ /\w+/g;
    },

    ##
    ## MODULE
    ##
    'M:s' => sub {
	warn "Use -M option at the beginning with module name.\n";
	if (my @modules = uniq($rcloader->modules())) {
	    warn "Available modules:\n";
	    warn "\t", join("\n\t", @modules), "\n";
	}
	exit 2;
    },

    ##
    ## UNDOCUMENTED
    ##
    ' clean                  !  ' => \ my $opt_clean ,

;

sub setopt {
    my $opt = ref $_[0] eq 'HASH' ? shift : {};
    my $name = shift;
    if (exists $optargs{$name}) {
	my $ref = $optargs{$name};
	if (ref $ref eq 'ARRAY') {
	    if ($opt->{append}) {
		push @$ref, @_;
	    } else {
		@$ref = @_;
	    }
	}
	elsif (ref $ref eq 'CODE') {
	    &$ref($name, @_);
	}
	elsif (ref $ref eq 'SCALAR') {
	    $$ref = shift;
	}
	else {
	    die "Object error.";
	}
    }
}

##
## @ARGV stuff
##

require Getopt::Long;
my $parser = Getopt::Long::Parser->new(
    config => [ qw(bundling no_getopt_compat no_ignore_case) ],
    );
sub configure_getopt { $parser->configure(@_) }

configure_getopt qw(debug) if $ENV{DEBUG_GETOPT};
$Getopt::EX::Loader::debug = 1 if $ENV{DEBUG_GETOPTEX};

## decode
my  @ORIG_ARGV =
    @ARGV = map { utf8::is_utf8($_) ? $_ : decode('utf8', $_) } @ARGV;

## ~/.greplerc
unless ((@ARGV and $ARGV[0] eq "--norc" and shift)
	or
	($ENV{GREPLE_NORC}) ) {
    $rcloader->load(FILE => "$ENV{HOME}/.greplerc");
}

## modules
$rcloader->deal_with(\@ARGV);

push @optargs, $rcloader->builtins;

## ENV
$ENV{'GREPLEOPTS'} and unshift @ARGV, shellwords($ENV{'GREPLEOPTS'});


## GetOptions
my @SAVEDARGV = @ARGV;
$parser->getoptions(@optargs) || usage();

if ($opt_version) {
    print "$version\n";
    exit 0;
}

our %opt_d;
@opt_d = map { split // } @opt_d;
@opt_d{@opt_d} = @opt_d;

if ($opt_d{o}) {
    warn "\@ARGV = ", join(' ', shellquote(@SAVEDARGV)), "\n";
}

## -m option
my @splicer = (not defined $opt_m) ? () : do {
    my @param = split /,/, $opt_m, -1;
    push @param, '' if @param % 2;
    if (notall { /^(-?\d+)?$/ } @param) {
	die "$opt_m: option format error.\n";
    }
    map {
	my($offset, $length) = @$_;
	if ($length ne '') {
	    sub { splice @{+shift}, $offset || 0, $length }
	} else {
	    sub { splice @{+shift}, $offset || 0 }
	}
    }
    pairs @param;
};

my $file_code;
my $default_icode = 'utf8';	# default input encoding
my @default_icode_list = qw(euc-jp 7bit-jis);
my $output_code;
my $default_ocode = 'utf8';	# default output encoding

$output_code = $opt_ocode || $default_ocode;
binmode STDOUT, ":encoding($output_code)";

## show unused option characters
if ($opt_d{u}) {
    my $s = join('','0'..'9',"\n",'a'..'z',"\n",'A'..'Z',"\n");
    map { /\|([0-9a-zA-Z])\b/ && $s =~ s/$1/./ } @optargs;
    die $s;
}

## show man pages
if ($opt_man or $opt_show or $opt_path) {
    my @module = map {
	/^-M(\w+(::\w++(?![=(]))*)/ ? "App::Greple::$1" : ()
    } @ORIG_ARGV;
    if (@module) {
	my $module = $module[-1];
	my $jp = first { -x "$_/perldocjp" } split /:/, $ENV{PATH};
	my $perldoc = $jp ? "perldocjp" : "perldoc";
	$ENV{PERL5LIB} = join ':', @INC;
	my $file = $module =~ s[::][/]gr . '.pm';
	die unless $INC{$file};
	if ($opt_man) {
	    exec "$perldoc $module" or die $!;
	} else {
	    chomp(my $file = `$perldoc -ml $module`);
	    if ($opt_path) {
		say $file;
	    } else {
		my $pager = $ENV{PAGER} || 'less';
		exec "$pager $file" or die $!;
	    }
	}
	exit;
    }
    pod2usage({-verbose => 2});
    die;
}

sub default_module {
    my $mod = shift;
    my $module = $mod->module;
    return 1 if $module =~ /\b \.greplerc $/x;
    return 1 if $module =~ /\b default $/x;
    return 0;
}

## setup file encoding
if (@opt_icode) {
    @opt_icode = map { split /[,\s]+/ } @opt_icode;
    if (grep { s/^\+// } @opt_icode) {
	unshift @opt_icode, @default_icode_list;
    }
    @opt_icode = uniq @opt_icode;
    if (@opt_icode > 1) {
	@opt_icode = grep { !/(?:auto|guess)$/i } @opt_icode;
	Encode::Guess->set_suspects(@opt_icode);
	$file_code = 'Guess';
    }
    elsif ($opt_icode[0] =~ /^(?:guess|auto)$/i) {
	Encode::Guess->set_suspects(@default_icode_list);
	$file_code = 'Guess';
    } else {
	$file_code = $opt_icode[0];
    }
}
else {
    $file_code = $default_icode;
}

##
## --filter
##
if ($opt_filter) {
    $opt_all = 1;
    push @opt_need, '0';
    $opt_exit //= 0;
}

##
## Patterns
##

my $pat_holder = App::Greple::Pattern::Holder->new;

my $FLAG_BASE = FLAG_NONE;
$FLAG_BASE |= FLAG_IGNORECASE if $opt_i;

if (@opt_f) {
    for my $opt_f (@opt_f) {
	$pat_holder->append({ flag => $FLAG_BASE, type => 'file',
			      $opt_select ? (select => $opt_select) : (),
			    },
			    $opt_f);
    }
} else {
    unless ($opt_filter or grep { $_->[0] !~ /^(not|may)/ } @opt_pattern) {
	unshift @opt_pattern, [ le => shift @ARGV // &usage ];
    }
}

my %pat_flag = (
    must => FLAG_REGEX | FLAG_COOK | FLAG_REQUIRED,
    not  => FLAG_REGEX | FLAG_COOK | FLAG_NEGATIVE,
    may  => FLAG_REGEX | FLAG_COOK | FLAG_OPTIONAL,
    le   => FLAG_REGEX | FLAG_COOK | FLAG_LEXICAL,
    and  => FLAG_REGEX | FLAG_COOK,
    re   => FLAG_REGEX,
    fe   => FLAG_NONE,
);
for (@opt_pattern) {
    my($attr, @opt) = @$_;
    my $flag = $FLAG_BASE | $pat_flag{$attr};
    $pat_holder->append({ flag => $flag, type => 'pattern' }, @opt);
}
# $pat_holder->optimize;

##
## if optional pattern exist, make all non-optional pattern as required
##
{
    my @patterns = $pat_holder->patterns;
    my @posi = grep { $_->is_positive } @patterns;
    my @opti = grep { $_->is_optional } @posi;
    if (@opti > 0) {
	for my $p (grep { !$_->is_optional } @posi) {
	    $p->flag($p->flag | FLAG_REQUIRED);
	}
    }
}

##
## set $count_must, $count_need and $opt_allow
##
my $count_must = 0;
my $count_need;
my $count_allow = 0;
{
    my $must = grep({ $_->is_required } $pat_holder->patterns);
    my $posi = grep({ $_->is_positive } $pat_holder->patterns) - $must;
    my $nega = grep({ $_->is_negative } $pat_holder->patterns);

    $count_must = $must // 0;
    $count_need = $must ? 0 : $posi;
    for (@opt_need) {
	if (/^-(\d+)$/) {	# --need -n
	    $count_need = $posi - $1;
	}
	elsif (/^\+(\d+)$/) {	# --need +n
	    $count_need += $1;
	}
	elsif (/^(\d+)$/) {	# --need n
	    $count_need = $1 - $must;
	}
	else {
	    die "$_ is not valid count.\n"
	}
    }

    $count_allow = 0;
    for (@opt_allow) {
	if (/^-(\d+)$/) {	# --allow -n
	    $count_allow = $nega - $1;
	}
	elsif (/^\+(\d+)$/) {	# --allow +n
	    $count_allow += $1;
	}
	elsif (/^(\d+)$/) {	# --allow n
	    $count_allow = $1;
	}
	else {
	    die "$_ is not valid count.\n"
	}
    }
}

##
## --matchcount
##
my $count_match_sub = sub {
    local $_ = shift or return;
    /[^\d,]/ and die "$_ is not valid count.\n";
    my @c = map { $_ eq '' ? 0 : int } split(/,/, $_, -1);
    if (@c == 1) {
	return sub { $_[0] == $c[0] };
    }
    push @c, -1 if @c % 2;
    return sub {
	my @n = @c;
	while (my($min, $max) = splice(@n, 0, 2)) {
	    return 0 if $_[0] < $min;
	    return 1 if $max <= 0 || $_[0] <= $max;
	}
	return 0;
    }
}->($opt_matchcount);

##
## setup input/output filter
##
my $filter_d = App::Greple::Filter->new->parse(@opt_if);
unless ($opt_noif) {
    $filter_d->append(
	[ sub { s/\.Z$//   }, 'zcat' ],
	[ sub { s/\.g?z$// }, 'gunzip -c' ],
	[ sub { m/\.pdf$/i }, 'pdftotext -nopgbrk - -' ],
	[ sub { s/\.gpg$// }, 'gpg --quiet --no-mdc-warning --decrypt' ],
	);
}

##------------------------------------------------------------
## miscellaneous setups
##

my @argv_files;
my $start_directory;
my $need_filename = ($opt_H or $opt_l);
my $current_file;

if (@opt_chdir) {
    $start_directory = getcwd;
    @opt_chdir = uniq(map { glob $_ } @opt_chdir);
    push @argv_files, splice(@ARGV);
    unless ($opt_h or
	    (@opt_chdir == 1 and @argv_files == 1 and @opt_glob == 0)) {
	$need_filename++;
    }
}
elsif (@opt_glob) {
    push @ARGV, map(glob, @opt_glob);
}

push(@ARGV, '-') unless @ARGV || @argv_files || @opt_glob || $opt_readlist;
if ((@ARGV > 1 or $opt_readlist) and not $opt_h) {
    $need_filename++;
}

$opt_filestyle = 'none' if not $need_filename;

$opt_join = 1 if $opt_joinby ne "";

##------------------------------------------------------------
## colors
##
our %colormap = (
    FILE     => "G",
    LINE     => "Y",
    BLOCK    => "B",
    TEXT     => "",
    BLOCKEND => "/WE",
    PROGRESS => "B",
    TOP      => "",
    MIDDLE   => "",
    BOTTOM   => "",
    );

our @colors;

use Getopt::EX::Colormap;
my $color_handler = Getopt::EX::Colormap
    ->new(HASH => \%colormap, LIST => \@colors)
    ->load_params(@opt_colormap);

my @default_color =
    $opt_ansicolor eq '16'
    ? qw(RD GD BD CD MD YD)
    : qw(000D/544 000D/454 000D/445
	 000D/455 000D/545 000D/554
	 000D/543 000D/453 000D/435
	 000D/534 000D/354 000D/345
	 000D/444
	 000D/433 000D/343 000D/334
	 000D/344 000D/434 000D/443
	 000D/333)
    ;

if ($color_handler->list == 0) {
    $color_handler->append
	($opt_colorful ? @default_color : $default_color[0]);
}

if ($opt_ansicolor eq '24bit') {
    no warnings 'once';
    $Getopt::EX::Colormap::RGB24 = 1;
}

for my $opt (@opt_face) {
    while ($opt =~ /(?[-+=]) (?[^-+=]*) | (?[^-+=]+) /xg) {
	my($mk, $s) = ($+{mk} // '', $+{s});
	for my $c (@colors) {
	    if ($mk eq '-') {
		$c =~ s/[\Q$s\E]//g if $s ne '';
	    } elsif ($mk eq '=') {
		$c = $s;
	    } elsif ($s ne '') {
		$c .= "^" if $c ne '';
		$c .= $s;
	    }
	}
    }
}

my $need_color = (($opt_color eq 'always')
		  or (($opt_color eq 'auto') and (!$opt_o and -t STDOUT)));

if (!$need_color) {
    $Getopt::EX::Colormap::NO_COLOR = 1;
}

my %_esc = ( t => "\t", n => "\n", r => "\r", f => "\f" );
sub expand_escape {
    $_[0] =~ s{\\(.)}{$_esc{$1} // $1}egr;
}

$_ = expand_escape($_) for values %opt_format;

my $blockend = "--";
if (defined $opt_blockend) {
    $blockend = expand_escape($opt_blockend);
}

my $_file     = sub { $color_handler->color('FILE' , sprintf($opt_format{FILE}, $_[0])) };
my $_line     = sub { $color_handler->color('LINE' , sprintf($opt_format{LINE}, $_[0])) };
my $_block    = sub { $color_handler->color('BLOCK', sprintf($opt_format{BLOCK}, $_[0])) };
my $_text     = sub { $color_handler->color('TEXT' , $_[0]) };
my $_blockend = $color_handler->color('BLOCKEND', $blockend);
my $_top      = $color_handler->color('TOP'     , $opt_frame_top);
my $_middle   = $color_handler->color('MIDDLE'  , $opt_frame_middle);
my $_bottom   = $color_handler->color('BOTTOM'  , $opt_frame_bottom);

sub index_color {
    $color_handler->index_color(@_);
}

sub color {
    $color_handler->color(@_);
}

my $uniq_color = UniqIndex->new(
    ignore_newline => 1,
    prepare => \@opt_uniqsub,
    );

sub dump_uniqcolor {
    my $list  = $uniq_color->list;
    my $count = $uniq_color->count;
    for my $i (keys @$list) {
	warn sprintf("%3d (%3d) %s\n",
		     $i, $count->[$i],
		     index_color($i, $list->[$i]));
    }
}

# --colorindex
my %color_index = map { uc $_ => 1 } $opt_colorindex =~ /\w/g;
my $indexer = do {
    if ($color_index{S}) {
	@colors = shuffle @colors;
    }
    if ($color_index{A} or $color_index{D}) {
	my $i = 0;
	Indexer->new(
	    index   => sub { $i++   },
	    reset   => sub { $i = 0 },
	    block   => $color_index{B},
	    reverse => $color_index{D},
	    );
    }
    elsif ($color_index{R}) {
	Indexer->new(index => sub { int rand @colors });
    }
    else { undef }
};
my $opt_uniqcolor = $color_index{U};

# -dc
if ($opt_d{c}) {
    my $dump = sub {
	local $_ = Dumper shift;
	s/^\s*'\K([^'\s]+)(?=')/color($1, $1)/mge;
	$_;
    };
    warn 'colormap = ', $dump->(\%colormap);
    warn 'colors = ', $dump->(\@colors);
}

##
## border regex
##
my $border_re = do {
    if ($opt_border) {
	qr/$opt_border/m;	# custom
    } elsif ($opt_p) {
	qr/(?:\A|\R)\K\R+/;	# paragraph
    } else {
	qr/^/m;			# line
    }
};

if ($opt_C) {
    $opt_A ||= $opt_C;
    $opt_B ||= $opt_C;
}
my %stat = (
    file_searched => 0,
    file_tried => 0,
    length => 0,
    match_effective => 0,
    match_positive => 0,
    match_negative => 0,
    match_block => 0,
    read_retry => 0,
    time_start => [],
    time_end => [],
    );
lock_keys %stat;

##
## Setup functions
##
for my $set (
    [ "print"   , \@opt_print   , 0 ],
    [ "begin"   , \@opt_begin   , 0 ],
    [ "end"     , \@opt_end     , 0 ],
    [ "prologue", \@opt_prologue, 0 ],
    [ "epilogue", \@opt_epilogue, 0 ],
    [ "callback", \@opt_callback, 0 ],
    [ "uniqsub" , \@opt_uniqsub , 0 ],
    [ "postgrep", \@opt_postgrep, 0 ],
    [ "block"   , \@opt_block   , 1 ], # need &
    [ "inside"  , \@opt_inside  , 1 ], # need &
    [ "outside" , \@opt_outside , 1 ], # need &
    [ "include" , \@opt_include , 1 ], # need &
    [ "exclude" , \@opt_exclude , 1 ], # need &
    ) {
    my($cat, $opt, $pattern) = @$set;
    for (@{$opt}) {
	next if callable $_;
	/^&\w+/ or next if $pattern;
	$_ = parse_func($_) or die "$cat function format error: $_\n";
    }
}

my $regions = App::Greple::Regions::Holder->new;
for my $set (
    [ \@opt_inside,  REGION_INSIDE  | REGION_UNION     ],
    [ \@opt_outside, REGION_OUTSIDE | REGION_UNION     ],
    [ \@opt_include, REGION_INSIDE  | REGION_INTERSECT ],
    [ \@opt_exclude, REGION_OUTSIDE | REGION_INTERSECT ])
{
    my($opt, $flag) = @$set;
    for my $spec (@$opt) {
	$regions->append(FLAG => $flag, SPEC => $spec);
    }
}

##------------------------------------------------------------

if ($opt_d{m}) {
    warn "Search pattern:\n";
    my $i;
    for my $pat ($pat_holder->patterns) {
	my $type =
	    $pat->is_required ? 'must' :
	    $pat->is_negative ? 'not' :
	    $pat->is_positive ? 'and' : 'else';
	my $target = $pat->regex // $pat->string;
	warn sprintf("  %4s %1s %s\n",
		     $type,
		     $pat->is_function ? '&' : '',
		     @colors > 1 ? index_color($i++, $target) : $target);
    }
    warn sprintf("must = %d, need = %d, allow = %d\n",
		 $count_must, $count_need, $count_allow);
}

## push post-process filter
if (@opt_pf) {
    push_output_filter(\*STDOUT, @opt_pf);
}

usage() and exit if defined $opt_usage;

open SAVESTDIN,  '<&', \*STDIN  or die "open: $!";
open SAVESTDOUT, '>&', \*STDOUT or die "open: $!";
open SAVESTDERR, '>&', \*STDERR or die "open: $!";

sub recover_stdin {
    open STDIN, '<&', \*SAVESTDIN or die "open: $!";
}
sub recover_stderr {
    open STDERR, '>&', \*SAVESTDERR or die "open: $!";
    binmode STDERR, ':encoding(utf8)';
}
sub recover_stdout {
    close STDOUT;
    open STDOUT, '>&', \*SAVESTDOUT or die "open: $!";
}
sub close_stdout {
    close SAVESTDOUT;
    close STDOUT;
}

sub read_stdin {  }

my $slurp = do {
    ##
    ## Setting utf8 warnings fatal makes it easy to find code conversion
    ## error, so you can choose appropriate file code or automatic code
    ## recognition, but loose a chance to find string in unrelated area.
    ##
    if ($opt_error =~ /^(?: fatal | skip | retry )$/x) {
	if ($opt_warn{read}) {
	    sub {
		use warnings FATAL => 'utf8';
		my $stdin = eval { local $/;  };
		warn $@ if $@;
		$stdin;
	    }
	} else {
	    sub {
		use warnings FATAL => 'utf8';
		eval { local $/;  };
	    }
	}
    } elsif ($opt_error eq 'ignore') {
	if ($opt_warn{read}) {
	    sub { local $/;  };
	} else {
	    sub {
		close STDERR;
		my $stdin = do { local $/;  };
		recover_stderr;
		$stdin;
	    }
	}
    } else {
	die "$opt_error: invalid action.\n";
    }
};

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

use constant {
    EL  => ansi_code('{EL}'),    # Erase Line
    ED  => ansi_code('{ED}'),    # Erase Display
    SCP => ansi_code('{SCP}'),   # Save Cursor Position
    RCP => ansi_code('{RCP}'),   # Restore Cursor Position
    DSC => ansi_code('{DECSC}'), # DEC Save Cursor
    DRC => ansi_code('{DECRC}'), # DEC Restore Cursor
    CR  => "\r",
};

my($progress_show, $progress_reset) = do {
    my $n;
    my($s, $e) = ! $need_color ? ('', '') :
	( ansi_code $colormap{PROGRESS}, ansi_code 'Z');
    my $print = sub { STDERR->printflush(DSC, $s, @_, $e, CR, DRC) };
    my $start = do {
	if ($opt_d{n} and $opt_d{f}) {
	    sub { $print->(++$n, " ", $current_file, ED) }
	}
	elsif ($opt_d{n}) {
	    sub { $print->(++$n) }
	}
	elsif ($opt_d{f}) {
	    sub { STDERR->printflush($current_file, ":\n") }
	}
	else {
	    undef;
	}
    };
    my $end = do {
	if ($opt_d{n}) {
	    sub { STDERR->printflush(ED) if $n }
	} else {
	    undef;
	}
    };
    ($start, $end);
};

##------------------------------------------------------------
## now ready to run.
##

## record start time
if ($opt_d{s}) {
    $stat{time_start} = [times];
}

for (@opt_prologue) { $_->call() }

grep_files();

for (@opt_epilogue) { $_->call() }

if ($opt_d{n}) {
    print STDERR ED;
}

if ($opt_uniqcolor and $opt_d{c}) {
    dump_uniqcolor();
}

## show statistic info
if ($opt_d{s}) {

    $stat{time_end} = [times];
    my @s = $stat{time_start}->@*;
    my @e = $stat{time_end}->@*;
    printf(STDERR "cpu %.3fu %.3fs\n", $e[0]-$s[0], $e[1]-$s[1]);

    local $" = ', ';
    for my $k (sort keys %stat) {
	my $v = $stat{$k};
	print STDERR
	    "$k: ",
	    ref $v eq 'ARRAY' ? "(@$v)" : $v,
	    "\n";
    }
}

close_stdout;

if ($opt_d{p}) {
    open STDOUT, ">&STDERR";
    system "ps -lww -p $$";
    system "lsof -p $$";
}

exit($opt_exit // ($stat{match_effective} == 0));

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

sub grep_files {
  FILE:
    while (defined($current_file = open_nextfile())) {
	my $content = $slurp->();
	$stat{file_tried}++;
	if (not defined $content) {
	    if ($opt_error eq 'fatal') {
		die "ABORT on $current_file\n";
	    }
	    if ($opt_error ne 'retry') {
		warn "SKIP $current_file\n" if $opt_warn{skip};
		next FILE;
	    }

	    # Try again
	    binmode STDIN, ':raw';
	    seek STDIN, 0, 0 or do {
		warn "SKIP $current_file (not seekable)\n"
		    if $opt_warn{skip};
		next FILE;
	    };
	    $content = $slurp->();
	    if (not defined $content) {
		warn "SKIP* $current_file\n" if $opt_warn{skip};
		next FILE;
	    }
	    warn "RETRY $current_file\n" if $opt_warn{retry};
	    $stat{read_retry}++;
	    binmode STDOUT, ':raw';
	}

	my $matched = grep_data(\$content);

	$stat{match_effective} += $matched;
	$stat{file_searched}++;
	$stat{length} += length $content;
    } continue {
	close STDIN; # wait;	# wait for 4.019 or earlier?
	# recover STDIN for opening '-' and some weird command which needs
	# STDIN opened (like unzip)
	recover_stdin;
	binmode STDOUT, ":encoding($output_code)";
    }
}

sub usage {
    pod2usage(-verbose => 0, -exitval => "NOEXIT");

    my $quote = qr/[\\(){}\|\*?]/;
    for my $bucket ($rcloader->buckets) {
	my $module = $bucket->module;
	print "    $module options:\n";
	for my $name ($bucket->options) {
	    my $help = $opt_usage ? "" : $bucket->help($name) // "";
	    next if $help eq 'ignore';
	    my @option = $bucket->getopt($name, ALL => 1);
	    printf("        %-20s %s\n", $name,
		   $help || join(' ', shellquote(@option)));
	}
	print "\n";
    }

    print "Version: $version\n";

    exit 2;
}

sub open_nextfile {

    ##
    ## --chdir
    ##
    while (@ARGV == 0 and @opt_chdir and (@argv_files or @opt_glob)) {
	my $dir = shift @opt_chdir;
	warn "chdir $dir/\n" if $opt_d{d};
	chdir $start_directory or die "$!: $start_directory\n";
	chdir $dir or die "$!: $dir\n";
	push @ARGV, @argv_files, map(glob, @opt_glob);
    }

    my $file;
    while (defined($file = shift(@ARGV)) ||
	   defined($file = $opt_readlist && read_stdin)) {
	$file = decode 'utf8', $file unless utf8::is_utf8 $file;
	$file =~ s/\n+$//;

	if (0) {}
	elsif ($file =~ /^https?:\/\//) {
	    open(STDIN, '-|') || exec("w3m -dump $file") || die "w3m: $!\n";
	}
	elsif ($file eq '-') {
	    # nothing to do
	}
	else {
	    open(STDIN, '<', $file) or do {
		warn "$file: $!\n" unless -l $file;
		next;
	    };
	}

	if (my @filters = $filter_d->get_filters($file)) {
	    push_input_filter({ &FILELABEL => $file }, @filters);
	}

	if ($file_code eq 'binary') {
	    binmode STDIN, ":raw";
	} else {
	    binmode STDIN, ":encoding($file_code)";
	}

	return $file;
    }
    undef;
}

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

sub grep_data {
    local *_ = shift;

    ##
    ## --begin
    ##
    for my $f (@opt_begin) {
	eval { $f->call(&FILELABEL => $current_file) };
	if (my $msg = $@) {
	    if ($msg =~ /^SKIP/i) {
		warn $@ if $opt_warn{begin};
		return 0;
	    } else {
		die $msg;
	    }
	}
    }

    $progress_show->() if $progress_show;

    my $grep = App::Greple::Grep->new(
	text         => \$_,
	filename     =>  $current_file,
	pattern      =>  $pat_holder,
	regions      =>  $regions,
	border       =>  $border_re,
	after        =>  $opt_A,
	before       =>  $opt_B,
	only         =>  $opt_o,
	all          =>  $opt_all,
	block        => \@opt_block,
	stretch      =>  $opt_stretch,
	must         =>  $count_must,
	need         =>  $count_need,
	countcheck   =>  $count_match_sub,
	allow        =>  $count_allow,
	strict       =>  $opt_strict,
	group_index  =>  do { local $_ = $opt_colorindex;
			      $opt_capture_group ? /G/i ? /P/i ? 3 : 2 : 1 : 0 },
	region_index =>  $opt_regioncolor,
	stat         => \%stat,
	callback     => \@opt_callback,
	alert_size   =>  $opt_alert{size},
	alert_time   =>  $opt_alert{time},
	join_blocks  =>  $opt_join_blocks,
    )->run;

    ## --postgrep
    for my $f (@opt_postgrep) {
	$f->call($grep);
	# remove emptied results
	my $ref = $grep->result_ref;
	@$ref = grep { @{$_} > 0 } @$ref;
    }
    ## -m
    for my $splice (@splicer) {
	$splice->($grep->result_ref);
    }

    my $matched = $grep->matched;
    if ($opt_l) {
	if ($matched) {
	    $progress_reset->() if $progress_reset;
	    print $current_file;
	    printf ":%d", scalar $grep->result if $opt_c;
	    print "\n";
	}
    }
    elsif ($opt_c) {
	$progress_reset->() if $progress_reset;
	print "$current_file:" if $need_filename;
	print scalar $grep->result, "\n";
    }
    elsif ($grep->result_ref->@*) {
	$progress_reset->() if $progress_reset;
	# open output filter
	@opt_of && push_output_filter(
	    { &FILELABEL => $current_file },
	    \*STDOUT, @opt_of);
	output($grep);
	@opt_of && recover_stdout;
    }

    ##
    ## --end
    ##
    for my $f (@opt_end) {
	$f->call(&FILELABEL => $current_file);
    }

    s/./\000/gs if $opt_clean;

    $matched;
}

sub output {
    my $grep = shift;
    my $file = $grep->{filename};

    if ($opt_filestyle eq 'once') {
	print $_file->($file), "\n";
    }

    my $need_blockend =
	!$opt_all &&
	$blockend ne '' &&
	($opt_blockend || $opt_p || $opt_A || $opt_B || @opt_block);

    my $line = 1;
    my $lastpos = 0;
    my @results = $grep->result;
    for my $rix (keys @results) {
	my $is_top    = $rix == 0;
	my $is_bottom = $rix == $#results;

	my $result = $results[$rix];
	my($blk, @result) = @{$result};
	my($block_start, $block_end, $block_number) = @$blk;
	$block_number //= 0;
	my $block = $grep->cut($block_start, $block_end);

	## --print
	if (@opt_print) {
	    local *_ = \$block;
	    for my $func (@opt_print) {
		$_ = $func->call(&FILELABEL => $file);
	    }
	    if (not $opt_continue) {
		print $block if defined $block;
		next;
	    }
	}

	if ($opt_n) {
	    my $gap = $grep->cut($lastpos, $block_start);
	    $line += $gap =~ tr/\n/\n/;
	}
	$lastpos = $block_end;

	# when --filestyle and/or --linestyle is "separate"
	grep { $_ } (
	    do {
		print $_file->($current_file)
		    if $opt_filestyle eq 'separate';
	    },
	    do {
		print $_line->($line)
		    if $opt_n and $opt_linestyle eq 'separate';
	    },
	    do {
		print $_block->($block_number)
		    if $opt_b and $opt_blockstyle eq 'separate';
	    },
	) and print "\n";

	if ($indexer) {
	    $indexer->reset if $indexer->block;
	    for ($indexer->reverse ? reverse @result : @result) {
		$_->[2] = $indexer->index;
	    }
	}

	my @slice = $grep->slice_result($result);
	my $mark = "\001";
	for my $i (keys @result) {
	    my($start, $end, $pi, $callback) = $result[$i]->@*;
	    local *b = \$slice[$i * 2 + 1];

	    ## run callback function
	    if ($callback) {
		$b = do {
		    if (ref $callback eq 'CODE') {
			$callback->($start, $end, $pi, $b);
		    }
		    elsif (callable($callback)) {
			$callback->call(
			    &FILELABEL => $file,
			    start => $start,
			    end   => $end,
			    index => $pi,
			    match => $b);
		    }
		    else { die }
		} // $b;
	    }

	    if ($opt_join) {
		if ($opt_n and $opt_linestyle eq 'line') {
		    $b =~ s/(?
		} else {
		    $b =~ s/(?
		}
	    }

	    $pi = $uniq_color->index($b) if $opt_uniqcolor;
	    $b = index_color($pi, $b);
	}

	$block = join '', @slice;
	next if $block eq "";

	my @line;
	if ($opt_n) {
	    if ($opt_linestyle eq 'line') {
		my $increment = $block =~ /[\n$mark]/ ? 1 : 0;
		$block =~ s{(?:(?$mark)|(?<=\n)|\A)(?=.)}{
		    	    push @line, $_line->($line) unless $+{mark};
			    $line += $increment;
			    $+{mark} ? $opt_joinby : '';
			   }gse;
	    } else {
		$line += $block =~ tr/\n/\n/;
	    }
	}

	$block = $_text->($block) if $colormap{TEXT} ne "";

	if (@line) {
	    $block =~ s/^/shift @line/mge;
	}

	if ($opt_b and $opt_blockstyle eq 'line') {
	    my $s = $_block->($block_number);
	    $block =~ s/^/$s/mg;
	}

	if ($opt_filestyle eq 'line') {
	    my $s = $_file->($file);
	    $block =~ s/^/$s/mg;
	}

	print "$_top\n" if $is_top && $_top ne '';
	print $block;
	print "\n" if $opt_newline and not $block =~ /\n\z/;
	print "$_blockend\n" if $need_blockend;
	if ($is_bottom) {
	    print "$_bottom\n" if $_bottom ne '';
	} else {
	    print "$_middle\n" if $_middle ne '';
	}
    }
}

__END__