File Coverage

blib/lib/App/Greple/Grep.pm

Criterion	Covered	Total	%
statement	364	417	87.2
branch	107	148	72.3
condition	43	67	64.1
subroutine	55	65	84.6
pod	5	22	22.7
total	574	719	79.8

package App::Greple::Grep;

use v5.24;
use warnings;

use Exporter 'import';
our @EXPORT      = qw(FILELABEL);
our %EXPORT_TAGS = ();
our @EXPORT_OK   = qw();

our @ISA = qw(App::Greple::Text);

use Data::Dumper;
use List::Util qw(min max reduce sum);
use Clone qw(clone);
use POSIX ();

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

use App::Greple::Common qw(%debug &FILELABEL);
use App::Greple::Regions;
use App::Greple::Pattern;

use constant {
    MATCH_NEGATIVE => 0,
    MATCH_POSITIVE => 1,
    MATCH_MUST     => 2,
};
push @EXPORT, qw(
    MATCH_NEGATIVE
    MATCH_POSITIVE
    MATCH_MUST
);

use constant {
    POSI_BASE => 0, POSI_POSI => 0, POSI_NEGA => 1, POSI_LIST => 2,
    NEGA_BASE => 3, NEGA_POSI => 3, NEGA_NEGA => 4, NEGA_LIST => 5,
    MUST_BASE => 6, MUST_POSI => 6, MUST_NEGA => 7, MUST_LIST => 8,
    INDX_POSI => 0, INDX_NEGA => 1, INDX_LIST => 2,
};

my @match_base;
BEGIN {
    $match_base[MATCH_POSITIVE] = POSI_BASE;
    $match_base[MATCH_NEGATIVE] = NEGA_BASE;
    $match_base[MATCH_MUST] = MUST_BASE;
}

sub category {
    my $obj = shift;
    return MATCH_MUST     if $obj->is_required;
    return MATCH_NEGATIVE if $obj->is_negative;
    return MATCH_POSITIVE;
}

sub new {
    my $class = shift;
    my $obj = bless { @_ }, $class;
    $obj;
}

sub run {
    my $self = shift;
    $self->prepare->compose;
}

package App::Greple::Grep::Block {
    use strict;
    sub min    :lvalue { $_[0]->[0] }
    sub max    :lvalue { $_[0]->[1] }
    sub number :lvalue { $_[0]->[2] }
}

package App::Greple::Grep::Match {
    use strict;
    sub min      :lvalue { $_[0]->[0] }
    sub max      :lvalue { $_[0]->[1] }
    sub index    :lvalue { $_[0]->[2] }
    sub callback :lvalue { $_[0]->[3] }
}

package App::Greple::Grep::Result {
    use strict;
    sub block   { $_[0]->[0] }
    sub matched { $_[0]->@[ 1 .. $#{$_[0]} ] }
    sub min     { $_[0]->block->min }
    sub max     { $_[0]->block->max }
    sub number  { $_[0]->block->number }
}

##
## Match multiple patterns in parallel using child processes.
## Each child scans $_ (shared by copy-on-write) with a single
## pattern and returns [from, to, index] triplets in packed binary
## format.  Returns a list indexed by pattern number; undef elements
## mean the pattern was not processed and should be matched in the
## calling process.
##
use constant NO_INDEX => ~0;

our $default_threshold = 1024 * 1024;

sub parallel_match {
    my $self = shift;
    my $patlist = shift;
    my $max = $self->{parallel} // 0;
    return () if $max < 2;
    my $threshold = $ENV{GREPLE_PARALLEL_THRESHOLD} // $default_threshold;
    return () if length() < $threshold;
    my @eligible = grep { not $patlist->[$_]->is_function } keys @$patlist;
    return () if @eligible < 2;
    warn sprintf("parallel_match: %d patterns, max %d processes\n",
		 scalar @eligible, $max) if $debug{m};
    my @result;
    while (my @chunk = splice @eligible, 0, $max) {
	my @child;
	for my $i (@chunk) {
	    my $pat = $patlist->[$i];
	    pipe(my $r, my $w) or last;
	    my $pid = fork;
	    if (not defined $pid) {	# fall back to sequential
		close $r; close $w;
		last;
	    }
	    if ($pid == 0) {
		close $r;
		binmode $w;
		my @p = match_regions(pattern => $pat->regex,
				      group => $self->{group_index},
				      index => $self->{group_index} >= 2);
		my $data = pack 'J*',
		    map { ($_->[0], $_->[1], $_->[2] // NO_INDEX) } @p;
		syswrite $w, $data if length $data;
		close $w;
		POSIX::_exit(0);
	    }
	    close $w;
	    binmode $r;
	    push @child, [ $i, $pid, $r ];
	}
	for (@child) {
	    my($i, $pid, $r) = @$_;
	    my $data = do { local $/; <$r> };
	    close $r;
	    waitpid $pid, 0;
	    next if $? != 0;		# fall back to sequential
	    my @v = unpack 'J*', $data // '';
	    my @p;
	    for (my $j = 0; $j < @v; $j += 3) {
		push @p, $v[$j+2] == NO_INDEX
		    ? [ @v[$j, $j+1] ] : [ @v[$j .. $j+2] ];
	    }
	    $result[$i] = \@p;
	}
    }
    @result;
}

##
## Compute line borders in a child process, overlapping with pattern
## matching in the calling process.  Border positions are independent
## from the match result and required only after the search.
##
sub start_borders {
    my $self = shift;
    return if $self->{BORDERS_CHILD};	# already started
    return if $self->{block}->@*;	# borders not used for --block
    my $threshold = $ENV{GREPLE_PARALLEL_THRESHOLD} // $default_threshold;
    return if length() < $threshold;
    pipe(my $r, my $w) or return;
    my $pid = fork;
    if (not defined $pid) {		# fall back to sequential
	close $r; close $w;
	return;
    }
    if ($pid == 0) {
	close $r;
	binmode $w;
	my $data = pack 'J*', match_borders $self->{border};
	syswrite $w, $data if length $data;
	close $w;
	POSIX::_exit(0);
    }
    close $w;
    binmode $r;
    $self->{BORDERS_CHILD} = [ $pid, $r ];
    warn "started borders child process\n" if $debug{m};
}

sub read_borders {
    my $self = shift;
    my($pid, $r) = @{delete $self->{BORDERS_CHILD}};
    my $data = do { local $/; <$r> };
    close $r;
    waitpid $pid, 0;
    return if $? != 0;			# fall back to sequential
    unpack 'J*', $data // '';
}

sub discard_borders {
    my $self = shift;
    if (my $child = delete $self->{BORDERS_CHILD}) {
	my($pid, $r) = @$child;
	kill 'TERM', $pid;
	close $r;
	waitpid $pid, 0;
    }
    $self;
}

sub prepare {
    my $self = shift;

    local *_ = $self->{text};
    my $pat_holder = $self->{pattern};
    my @blocks;

    $self->{RESULT} = [];
    $self->{BLOCKS} = [];

    ##
    ## build match result list
    ##
    my @result;
    my $positive_count = 0;
    my $group_index_offset = 0;
    my @patlist = $pat_holder->patterns;
    my @parallel = $self->parallel_match(\@patlist);
    while (my($i, $pat) = each @patlist) {
	my($func, @args) = do {
	    if ($pat->is_function) {
		$pat->function;
	    } else {
		Getopt::EX::Func->new(\&match_regions,
				      pattern => $pat->regex,
				      group => $self->{group_index},
				      index => $self->{group_index} >= 2,
		    );
	    }
	};
	my @p = $parallel[$i]
	    ? @{$parallel[$i]}
	    : $func->call(@args, &FILELABEL => $self->{filename});
	if (@p == 0) {
	    ##
	    ## $self->{need} can be negative value, which means
	    ## required pattern can be compromised upto that number.
	    ##
	    return $self->discard_borders if $pat->is_required and $self->{need} >= 0;
	    ##
	    ## Update offset even when no match for --ci=G
	    ##
	    if ($self->{group_index} == 2 and not $pat->is_function) {
		$group_index_offset += $pat->group_count //= do {
		    "" =~ /@{[$pat->regex]}?/;
		    $#+ || 1;
		};
	    }
	} else {
	    bless $_, 'App::Greple::Grep::Match' for @p;
	    if ($pat->is_positive) {
		##
		## Borders are required only when something matched.
		## Do not fork a child process for unmatched files.
		##
		$self->start_borders if $self->{parallel} and not @blocks;
		push @blocks, @{clone(\@p)};
		$self->{stat}->{match_positive} += @p;
		$positive_count++;
	    }
	    else {
		$self->{stat}->{match_negative} += @p;
	    }
	    ##
	    ## Adjust group index for --ci=G option
	    ## group_index: 0=off, 1=group, 2=sequential, 3=per-pattern
	    ##
	    if ($self->{group_index} == 2) {
		my $max_index = 0;
		for (@p) {
		    if (defined $_->index) {
			$_->index += $group_index_offset;
			$max_index = $_->index + 1 if $_->index >= $max_index;
		    }
		}
		$group_index_offset = $max_index;
	    }
	    $_->index //= $i for @p;
	    if (my $n = $self->{callback}->@*) {
		if (my $callback = $self->{callback}->[ $i % $n ]) {
		    $_->callback //= $callback for @p;
		}
	    }
	}
	push @result, \@p;
    }
    $self->{stat}->{match_block} += @blocks;

    ##
    ## optimization for inadequate match
    ##
    return $self->discard_borders if $positive_count < $self->{need} + $self->{must};

    ##
    ## --inside, --outside
    ##
    if (my @reg_union = $self->{regions}->union) {
	my @tmp = map { [] } @result;
	while (my($regi, $reg) = each @reg_union) {
	    my @select = get_regions($self->{filename}, \$_, $reg->spec);
	    @select or next if $reg->is_inside;
	    while (my($resi, $r) = each @result) {
		my @l = select_regions({ strict => $self->{strict} },
				       $r, \@select, $reg->flag);
		if ($self->{region_index} // @result == 1) {
		    map { $_->[2] = $regi } @l;
		}
		push @{$tmp[$resi]}, @l;
	    }
	}
	@result = map { [ merge_regions { nojoin => 1, destructive => 1 }, @$_ ] } @tmp;
    }

    ##
    ## --include, --exclude
    ##
    for my $reg ($self->{regions}->intersect) {
	my @select = get_regions($self->{filename}, \$_, $reg->spec);
	@select or next if not $reg->is_outside;
	for my $r (@result) {
	    @$r = select_regions({ strict => $self->{strict} },
				 $r, \@select, $reg->flag);
	}
    }

    ##
    ## Setup BLOCKS
    ##
    my $bp = $self->{BLOCKS} = [ do {
	if ($self->{block}->@*) {		# --block
	    my $text = \$_;
	    merge_regions { nojoin => 1, destructive => 1 }, map {
		get_regions($self->{filename}, $text, $_);
	    } $self->{block}->@*;
	}
	elsif (@blocks) {			# from matched range
	    my %opt = ( A => $self->{after},
		        B => $self->{before},
		        border => [ $self->borders ] );
	    my $blocker = smart_blocker(\%opt);
	    merge_regions { nojoin => 1, destructive => 1 }, map {
		[ $blocker->(\%opt, $_->min, $_->max) ]
	    } @blocks;
	}
	else {
	    ( [ 0, length ] );			# nothing matched
	}
    } ];
    $self->discard_borders;	# no-op if consumed by borders()
    while (my($i, $blk) = each @$bp) {
	bless $blk, 'App::Greple::Grep::Block';
	# set 1-origined block number in the 3rd entry
	$blk->number = $i + 1;
    }

    ##
    ## build match table
    ##
    my @match_table = map { [ 0, 0, [], 0, 0, [], 0, 0, [] ] } @$bp;
    while (my($ri, $r) = each @result) {
	my $base = $match_base[category($patlist[$ri])];
	my @b = classify_regions({ strict => $self->{strict} }, $r, $bp);
	while (my($bi, $b) = each @b) {
	    my $t = $match_table[$bi];
	    if (@$b) {
		${$t}[$base + INDX_POSI]++;
		push @{$t->[$base + INDX_LIST]}, @$b;
	    } else {
		${$t}[$base + INDX_NEGA]++;
	    }
	}
    }

    show_match_table(\@match_table) if $debug{g};

    $self->{MATCH_TABLE} = \@match_table;

    $self;
}

sub compose {
    my $self = shift;
    my $bp = $self->{BLOCKS};
    my $mp = $self->{MATCH_TABLE};

    ##
    ## now it is quite easy to get effective blocks
    ##
    my $compromize = $self->{need} < 0 ? abs($self->{need}) : 0;
    my @effective_index = grep(
	$mp->[$_][MUST_NEGA] <= $compromize &&
	$mp->[$_][POSI_POSI] >= $self->{need} &&
	$mp->[$_][NEGA_POSI] <= $self->{allow},
	keys @$bp)
	or return $self;

    ##
    ## --matchcount
    ##
    if (my $countcheck = $self->{countcheck}) {
	@effective_index = do {
	    grep { $countcheck->(int($mp->[$_][POSI_LIST]->@*)) }
	    @effective_index;
	}
	or return $self;
    }

    ##
    ## --block with -ABC option
    ##
    if ($self->{block}->@* and ($self->{after} or $self->{before})) {
	my @mark;
	for my $i (@effective_index) {
	    map { $mark[$_] = 1 if $_ >= 0 }
	    $i - $self->{before} .. $i + $self->{after};
	}
	@effective_index = grep $mark[$_], keys @$bp;
    }

    ##
    ## compose the result
    ##
    my @list = ();
    for my $bi (@effective_index) {
	my @matched = merge_regions({ nojoin => 1, destructive => 1 },
				    $mp->[$bi][MUST_LIST]->@*,
				    $mp->[$bi][POSI_LIST]->@*,
				    $mp->[$bi][NEGA_LIST]->@*);
	if ($self->{stretch}) {
	    my $b = $bp->[$bi];
	    my $m = $matched[0];
	    my $i = min map { $_->[2] // 0 } @matched;
	    @matched = [ $b->min, $b->max, $i, $m->[3] ];
	}
	if ($self->{only}) {
	    push @list, map({ [ $_, $_ ] } @matched);
	} elsif ($self->{all}) {
	    push @list, [ [ 0, length ] ] if @list == 0;
	    push @{$list[0]}, @matched;
	} else {
	    push @list, [ $bp->[$bi], @matched ];
	}
    }
    for my $r (@list) {
	bless $r, 'App::Greple::Grep::Result';
	bless $r->block, 'App::Greple::Grep::Block';
	for my $m ($r->matched) {
	    bless $m, 'App::Greple::Grep::Match';
	}
    }

    ##
    ## --join-blocks
    ##
    if ($self->{join_blocks} and @list > 1) {
	reduce {
	    if ($a->[-1][0]->max == $b->[0]->min) {
		$a->[-1][0]->max  = $b->[0]->max;
		push @{$a->[-1]}, splice @$b, 1;
	    } else {
		push @$a, $b;
	    }
	    $a;
	} \@list, splice @list, 1;
    }

    ##
    ## ( [ [blockstart, blockend, number ], [start, end], [start, end], ... ],
    ##   [ [blockstart, blockend, number ], [start, end], [start, end], ... ], ... )
    ##
    $self->{RESULT} = \@list;

    $self;
}

sub borders {
    my $self = shift;
    local $SIG{ALRM};
    my $alarm_start;
    if ($self->{alert_size} and length >= $self->{alert_size}) {
	$alarm_start = time;
	$SIG{ALRM} = sub {
	    $SIG{ALRM} = undef;
	    STDERR->printflush(
		$self->{filename} .
		": Counting lines, and it may take longer...\n");
	};
	alarm $self->{alert_time};
        warn "alert timer start ($alarm_start)\n" if $debug{a};
    }
    my @borders = do {
	if ($self->{BORDERS_CHILD}) {
	    my @b = $self->read_borders;
	    @b ? @b : match_borders $self->{border};
	} else {
	    match_borders $self->{border};
	}
    };
    if (defined $alarm_start) {
	if ($SIG{ALRM}) {
	    alarm 0;
	    warn "reset alert timer\n" if $debug{a};
	} else {
	    STDERR->printflush(sprintf("Count %d lines in %d seconds.\n",
				       @borders - 1,
				       time - $alarm_start));
	}
    }
    @borders;
}

sub result_ref {
    my $obj = shift;
    $obj->{RESULT};
}

sub result {
    my $obj = shift;
    @{ $obj->{RESULT} };
}

sub matched {
    my $obj = shift;
    sum(map { $_->@* - 1 } $obj->result) // 0;
}

sub blocks {
    my $obj = shift;
    $obj->{BLOCKS}->@*;
}

##
## Cut all result blocks (and gaps between them) from the text in a
## single pass.  Returns ( gap0, block0, gap1, block1, ..., rest ),
## or an empty list when not applicable.  Character based substr on
## a large utf8 string requires linear scan for every call to convert
## character offset to byte offset, so cutting each block separately
## makes the output routine quadratic.
##
sub slice_blocks {
    my $self = shift;
    my @blocks = map { $_->block } $self->result;
    return () if @blocks < 2;
    my $pos = 0;
    for (@blocks) {
	return () if $_->[0] < $pos;	# not in order
	$pos = $_->[1];
    }
    my $template = unpack_template(\@blocks, 0);
    unpack $template, ${ $self->{text} };
}

sub slice_result {
    my $obj = shift;
    my $result = shift;
    my($block, @list) = @$result;
    my $text = @_ ? shift : $obj->cut(@$block);
    my $template = unpack_template(\@list, $block->min);
    unpack($template, $text);
}

sub slice_index {
    my $obj = shift;
    my $result = shift;
    my($block, @list) = @$result;
    map { $_ * 2 + 1 } keys @list;
}

sub unpack_template {
    ##
    ## make template to split result text into matched and unmatched parts
    ##
    my($matched, $offset) = @_;
    my @len;
    for (@$matched) {
	my($s, $e) = @$_;
	$s = $offset if $s < $offset;
	push @len, $s - $offset, $e - $s;
	$offset = $e;
    }
    join '', map "a$_", @len, '*';
}

sub show_match_table {
    my $table = shift;
    local $Data::Dumper::Terse = 1;
    while (my($i, $e) = each @$table) {
	printf STDERR
	    "%4d %s", $i++, Dumper($e) =~ s/\s+(?!$)/ /gsr;
    }
}

sub get_regions {
    my $file = shift;
    local *_ = shift;
    my $pattern = shift;

    ## func object
    if (callable $pattern) {
	$pattern->call(&FILELABEL => $file);
    }
    ## pattern
    else {
	match_regions(pattern => $pattern);
    }
}

sub smart_blocker {
    my $opt = shift;
    return \&blocker if $opt->{A} or $opt->{B};
    my $from = my $to = -1;
    sub {
	if ($from <= $_[1] and $_[2] < $to) {
	    return($from, $to);
	}
	($from, $to) = &blocker;
    }
}

use List::BinarySearch qw(binsearch_pos);

sub blocker {
    my($opt, $from, $to) = @_;
    my $border = $opt->{border};

    my $bi = binsearch_pos { $a <=> $b } $from, @$border;
    $bi-- if $border->[$bi] != $from;
    $bi = max 0, $bi - $opt->{B} if $opt->{B};

    my $ei = binsearch_pos { $a <=> $b } $to, @$border;
    $ei++ if $ei == $bi and $ei < $#{$border};
    $ei = min $#{$border}, $ei + $opt->{A} if $opt->{A};

    @$border[ $bi, $ei ];
}

package App::Greple::Text {
    use strict;
    use warnings;
    use overload '""' => sub { ${ $_[0]->{text} } };
    sub new {
	my $class = shift;
	bless { text => \$_[0] }, $class;
    }
    sub text { ${ $_[0]->{text} } }
    sub cut {
	my($obj, $from, $to) = @_;
	substr ${ $obj->{text} }, $from, $to - $from;
    }
}

1;

__END__