File Coverage

blib/lib/String/Wildcard/Bash.pm

Criterion	Covered	Total	%
statement	59	60	98.3
branch	39	46	84.7
condition	17	19	89.4
subroutine	8	8	100.0
pod	3	3	100.0
total	126	136	92.6

package String::Wildcard::Bash;

our $DATE = '2019-08-30'; # DATE
our $VERSION = '0.043'; # VERSION

use 5.010001;
use strict;
use warnings;

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
                       $RE_WILDCARD_BASH
                       contains_wildcard
                       convert_wildcard_to_sql
                       convert_wildcard_to_re
               );

our $re_bash_brace_element =
    qr(
          (?:(?:\\\\ | \\, | \\\{ | \\\} | [^\\\{,\}])*)
  )x;

# note: order is important here, brace encloses the other
our $RE_WILDCARD_BASH =
    qr(
          # non-escaped brace expression, with at least one comma
          (?P
              (?\\\\)*\{
              (?P
                  $re_bash_brace_element(?:, $re_bash_brace_element )+
              )
              (?
          )
      |
          # non-escaped brace expression, to catch * or ? or [...] inside so
          # they don't go to below pattern, because bash doesn't consider them
          # wildcards, e.g. '/{et?,us*}' expands to '/etc /usr', but '/{et?}'
          # doesn't expand at all to /etc.
          (?P
              (?
              $re_bash_brace_element
              (?
          )
      |
          (?P
              # non-empty, non-escaped character class
              (?
              (?:  \\\\ | \\\[ | \\\] | [^\\\[\]] )+
              (?
          )
      |
          (?P
              # non-escaped * and ?
              (?
          )
      |
          (?P
              # non-escaped % and ?
              (?
          )
      |
          (?P
              [^\\\[\]\{\}*?%_]+
          |
              .+?
          )
      )ox;

sub contains_wildcard {
    my $str = shift;

    while ($str =~ /$RE_WILDCARD_BASH/go) {
        my %m = %+;
        return 1 if $m{bash_brace} || $m{bash_class} || $m{bash_joker};
    }
    0;
}

sub convert_wildcard_to_sql {
    my $opts = ref $_[0] eq 'HASH' ? shift : {};
    my $str = shift;

    my @res;
    my $p;
    while ($str =~ /$RE_WILDCARD_BASH/g) {
        my %m = %+;
        if (defined($p = $m{bash_brace_content})) {
            die "Cannot convert brace pattern '$p' to SQL";
        } elsif ($p = $m{bash_joker}) {
            if ($m{bash_joker} eq '*' || $m{bash_joker} eq '**') {
                push @res, "%";
            } else {
                push @res, "_";
            }
        } elsif ($p = $m{sql_joker}) {
            push @res, "\\$p";
        } elsif (defined($p = $m{literal_brace_single_element})) {
            die "Currently cannot convert brace literal '$p' to SQL";
        } elsif (defined($p = $m{bash_class})) {
            die "Currently cannot convert class pattern '$p' to SQL";
        } elsif (defined($p = $m{literal})) {
            push @res, $p;
        }
    }

    join "", @res;
}

sub convert_wildcard_to_re {
    my $opts = ref $_[0] eq 'HASH' ? shift : {};
    my $str = shift;

    my $opt_brace   = $opts->{brace} // 1;
    my $opt_dotglob = $opts->{dotglob} // 0;

    my @res;
    my $p;
    while ($str =~ /$RE_WILDCARD_BASH/g) {
        my %m = %+;
        if (defined($p = $m{bash_brace_content})) {
            push @res, quotemeta($m{slashes_before_bash_brace}) if
                $m{slashes_before_bash_brace};
            if ($opt_brace) {
                my @elems;
                while ($p =~ /($re_bash_brace_element)(,|\z)/g) {
                    push @elems, $1;
                    last unless $2;
                }
                #use DD; dd \@elems;
                push @res, "(?:", join("|", map {
                    convert_wildcard_to_re({
                        bash_brace => 0,
                        dotglob    => $opt_dotglob || @res,
                    }, $_)} @elems), ")";
            } else {
                push @res, quotemeta($m{bash_brace});
            }

        } elsif (defined($p = $m{bash_joker})) {
            if ($p eq '?') {
                push @res, '.';
            } elsif ($p eq '*') {
                push @res, $opt_dotglob || @res ? '.*' : '[^.].*';
            } elsif ($p eq '**') {
                push @res, '.*';
            }

        } elsif (defined($p = $m{literal_brace_single_element})) {
            push @res, quotemeta($p);
        } elsif (defined($p = $m{bash_class})) {
            # XXX no need to escape some characters?
            push @res, $p;
        } elsif (defined($p = $m{sql_joker})) {
            push @res, quotemeta($p);
        } elsif (defined($p = $m{literal})) {
            push @res, quotemeta($p);
        }
    }

    join "", @res;
}

1;
# ABSTRACT: Bash wildcard string routines

__END__