File Coverage

blib/lib/String/Wildcard/Bash.pm

Criterion	Covered	Total	%
statement	96	102	94.1
branch	58	68	85.2
condition	37	41	90.2
subroutine	13	14	92.8
pod	9	9	100.0
total	213	234	91.0

package String::Wildcard::Bash;

use 5.010001;
use strict;
use warnings;

use Exporter 'import';

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2022-08-06'; # DATE
our $DIST = 'String-Wildcard-Bash'; # DIST
our $VERSION = '0.044'; # VERSION

our @EXPORT_OK = qw(
                       $RE_WILDCARD_BASH
                       contains_wildcard
                       contains_brace_wildcard
                       contains_class_wildcard
                       contains_joker_wildcard
                       contains_qmark_wildcard
                       contains_glob_wildcard
                       contains_globstar_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 contains_brace_wildcard {
    my $str = shift;

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

sub contains_joker_wildcard {
    my $str = shift;

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

sub contains_class_wildcard {
    my $str = shift;

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

sub contains_qmark_wildcard {
    my $str = shift;

    while ($str =~ /$RE_WILDCARD_BASH/go) {
        my %m = %+;
        return 1 if $m{bash_joker} && $m{bash_joker} eq '?';
    }
    0;
}

sub contains_glob_wildcard {
    my $str = shift;

    while ($str =~ /$RE_WILDCARD_BASH/go) {
        my %m = %+;
        return 1 if $m{bash_joker} && $m{bash_joker} eq '*';
    }
    0;
}

sub contains_globstar_wildcard {
    my $str = shift;

    while ($str =~ /$RE_WILDCARD_BASH/go) {
        my %m = %+;
        return 1 if $m{bash_joker} && $m{bash_joker} eq '**';
    }
    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 $opt_globstar = $opts->{globstar} // 0;
    my $opt_ps       = $opts->{path_separator} // '/';

    die "Please use a single character for path_separator" unless length($opt_ps) == 1;
    my $q_ps =
        $opt_ps eq '-' ? "\\-" :
        $opt_ps eq '/' ? '/' :
        quotemeta($opt_ps);

    my $re_not_ps        = "[^$q_ps]";
    my $re_not_dot       = "[^.]";
    my $re_not_dot_or_ps = "[^.$q_ps]";

    my @res;
    my $p;
    my $after_pathsep;
    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({
                        brace    => 0,
                        dotglob  => $opt_dotglob,
                        globstar => $opt_globstar,
                    }, $_)} @elems), ")";
            } else {
                push @res, quotemeta($m{bash_brace});
            }

        } elsif (defined($p = $m{bash_joker})) {
            if ($p eq '?') {
                push @res, '.';
            } elsif ($p eq '*' || $p eq '**' && !$opt_globstar) {
                push @res, $opt_dotglob || (@res && !$after_pathsep) ?
                    "$re_not_ps*" : "$re_not_dot_or_ps$re_not_ps*";
            } elsif ($p eq '**') { # and with 'globstar' option set
                if ($opt_dotglob) {
                    push @res, '.*';
                } elsif (@res && !$after_pathsep) {
                    push @res, "(?:$re_not_ps*)(?:$q_ps+$re_not_dot_or_ps$re_not_ps*)*";
                } else {
                    push @res, "(?:$re_not_dot_or_ps$re_not_ps*)(?:$q_ps+$re_not_dot_or_ps$re_not_ps*)*";
                }
           }

        } 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);
        }

        $after_pathsep = defined($m{literal}) && substr($m{literal}, -1) eq $opt_ps;
    }

    join "", @res;
}

1;
# ABSTRACT: Bash wildcard string routines

__END__