package App::Greple::Pattern::Holder; use v5.14; use warnings; use Data::Dumper; use Carp; use Exporter 'import'; our @EXPORT = (); our %EXPORT_TAGS = (); our @EXPORT_OK = qw(); use App::Greple::Pattern; sub new { my $class = shift; my $obj = bless [], $class; $obj; } sub append { my $obj = shift; my $arg = ref $_[0] eq 'HASH' ? shift : {}; return $obj unless @_; $arg->{type} //= 'pattern'; if ($arg->{type} eq 'file') { $obj->load_file($arg, @_); return $obj; } if ($arg->{flag} & FLAG_LEXICAL) { for (@_) { $obj->lexical_opt($arg, $_); } return $obj; } if ($arg->{flag} & FLAG_OR) { $arg->{flag} &= ~FLAG_OR; my @p = map { App::Greple::Pattern->new ($_, flag => $arg->{flag} & ~FLAG_IGNORECASE) ->cooked; } @_; my $p = "(?x)\n" . join(" |\n", map { s/(\s)/\\$1/gr } @p); $arg->{flag} |= FLAG_REGEX; $arg->{flag} &= ~FLAG_COOK; push @$obj, App::Greple::Pattern->new($p, flag => $arg->{flag}); return $obj; } for (@_) { push @$obj, App::Greple::Pattern->new($_, flag => $arg->{flag}); } $obj; } sub optimize { my $obj = shift; # collect required pattern at the top of list @$obj = ( grep( { $_->is_required } @$obj ), grep( { ! $_->is_required } @$obj ) ); $obj; } sub lexical_opt { my($obj, $arg, $opt) = @_; unless ($arg->{flag} & FLAG_LEXICAL) { die "Unexpected flag value ($arg->{flag})"; } my $orig_flag = $arg->{flag} & ~FLAG_LEXICAL; my @or; for (split /(?append({ flag => $flag }, $_) if $_ ne ''; } if (@or) { my $flag = $orig_flag | FLAG_OR; $obj->append({ flag => $flag }, @or); } } use Getopt::EX::Numbers; sub load_file { my $obj = shift; my $arg = ref $_[0] eq 'HASH' ? shift : {}; $arg->{type} = 'pattern'; my $flag = ( $arg->{flag} // 0 ) | FLAG_REGEX | FLAG_COOK | FLAG_OR; for my $file (@_) { my $select = (!-f $file and $file =~ s/\[([\d:,]+)\]$//) ? $1 : undef; open my $fh, '<:encoding(utf8)', $file or die "$file: $!\n"; my @p = do { map { chomp ; s{\s*//.*}{} ; $_ } grep { not m{^\s*(?:#|//|$)} } <$fh> }; close $fh; if ($select //= $arg->{select}) { my $numbers = Getopt::EX::Numbers->new(min => 1, max => 0+@p); my @select = do { map { $_ - 1 } sort { $a <=> $b } grep { $_ <= @p } map { $numbers->parse($_)->sequence } split /,/, $select; }; @p = @p[@select]; } $obj->append({ flag => $flag }, @p); } } sub patterns { my $obj = shift; @{ $obj }; } 1;