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


line stmt bran cond sub pod time code
1             package String::Wildcard::Bash;
2              
3 1     1   59364 use 5.010001;
  1         14  
4 1     1   5 use strict;
  1         2  
  1         17  
5 1     1   4 use warnings;
  1         2  
  1         21  
6              
7 1     1   4 use Exporter 'import';
  1         1  
  1         250  
8              
9             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
10             our $DATE = '2022-08-06'; # DATE
11             our $DIST = 'String-Wildcard-Bash'; # DIST
12             our $VERSION = '0.044'; # VERSION
13              
14             our @EXPORT_OK = qw(
15             $RE_WILDCARD_BASH
16             contains_wildcard
17             contains_brace_wildcard
18             contains_class_wildcard
19             contains_joker_wildcard
20             contains_qmark_wildcard
21             contains_glob_wildcard
22             contains_globstar_wildcard
23             convert_wildcard_to_sql
24             convert_wildcard_to_re
25             );
26              
27             our $re_bash_brace_element =
28             qr(
29             (?:(?:\\\\ | \\, | \\\{ | \\\} | [^\\\{,\}])*)
30             )x;
31              
32             # note: order is important here, brace encloses the other
33             our $RE_WILDCARD_BASH =
34             qr(
35             # non-escaped brace expression, with at least one comma
36             (?P
37             (?\\\\)*\{
38             (?P
39             $re_bash_brace_element(?:, $re_bash_brace_element )+
40             )
41             (?
42             )
43             |
44             # non-escaped brace expression, to catch * or ? or [...] inside so
45             # they don't go to below pattern, because bash doesn't consider them
46             # wildcards, e.g. '/{et?,us*}' expands to '/etc /usr', but '/{et?}'
47             # doesn't expand at all to /etc.
48             (?P
49             (?
50             $re_bash_brace_element
51             (?
52             )
53             |
54             (?P
55             # non-empty, non-escaped character class
56             (?
57             (?: \\\\ | \\\[ | \\\] | [^\\\[\]] )+
58             (?
59             )
60             |
61             (?P
62             # non-escaped * and ?
63             (?
64             )
65             |
66             (?P
67             # non-escaped % and ?
68             (?
69             )
70             |
71             (?P
72             [^\\\[\]\{\}*?%_]+
73             |
74             .+?
75             )
76             )ox;
77              
78             sub contains_wildcard {
79 43     43 1 13502 my $str = shift;
80              
81 43         297 while ($str =~ /$RE_WILDCARD_BASH/go) {
82 1     1   358 my %m = %+;
  1         333  
  1         973  
  85         535  
83 85 100 100     735 return 1 if $m{bash_brace} || $m{bash_class} || $m{bash_joker};
      100        
84             }
85 20         79 0;
86             }
87              
88             sub contains_brace_wildcard {
89 6     6 1 2864 my $str = shift;
90              
91 6         41 while ($str =~ /$RE_WILDCARD_BASH/go) {
92 10         65 my %m = %+;
93 10 100       50 return 1 if $m{bash_brace};
94             }
95 5         18 0;
96             }
97              
98             sub contains_joker_wildcard {
99 0     0 1 0 my $str = shift;
100              
101 0         0 while ($str =~ /$RE_WILDCARD_BASH/go) {
102 0         0 my %m = %+;
103 0 0       0 return 1 if $m{bash_joker};
104             }
105 0         0 0;
106             }
107              
108             sub contains_class_wildcard {
109 6     6 1 1766 my $str = shift;
110              
111 6         43 while ($str =~ /$RE_WILDCARD_BASH/go) {
112 10         67 my %m = %+;
113 10 100       50 return 1 if $m{bash_class};
114             }
115 5         25 0;
116             }
117              
118             sub contains_qmark_wildcard {
119 6     6 1 1756 my $str = shift;
120              
121 6         41 while ($str =~ /$RE_WILDCARD_BASH/go) {
122 10         66 my %m = %+;
123 10 100 100     59 return 1 if $m{bash_joker} && $m{bash_joker} eq '?';
124             }
125 5         20 0;
126             }
127              
128             sub contains_glob_wildcard {
129 6     6 1 1871 my $str = shift;
130              
131 6         42 while ($str =~ /$RE_WILDCARD_BASH/go) {
132 10         67 my %m = %+;
133 10 100 100     57 return 1 if $m{bash_joker} && $m{bash_joker} eq '*';
134             }
135 5         18 0;
136             }
137              
138             sub contains_globstar_wildcard {
139 6     6 1 1787 my $str = shift;
140              
141 6         41 while ($str =~ /$RE_WILDCARD_BASH/go) {
142 10         65 my %m = %+;
143 10 100 100     59 return 1 if $m{bash_joker} && $m{bash_joker} eq '**';
144             }
145 5         18 0;
146             }
147              
148             sub convert_wildcard_to_sql {
149 15 50   15 1 1886 my $opts = ref $_[0] eq 'HASH' ? shift : {};
150 15         26 my $str = shift;
151              
152 15         21 my @res;
153             my $p;
154 15         121 while ($str =~ /$RE_WILDCARD_BASH/g) {
155 41         242 my %m = %+;
156 41 100       162 if (defined($p = $m{bash_brace_content})) {
    100          
    100          
    100          
    100          
    50          
157 1         9 die "Cannot convert brace pattern '$p' to SQL";
158             } elsif ($p = $m{bash_joker}) {
159 7 100 100     23 if ($m{bash_joker} eq '*' || $m{bash_joker} eq '**') {
160 4         20 push @res, "%";
161             } else {
162 3         13 push @res, "_";
163             }
164             } elsif ($p = $m{sql_joker}) {
165 2         9 push @res, "\\$p";
166             } elsif (defined($p = $m{literal_brace_single_element})) {
167 1         9 die "Currently cannot convert brace literal '$p' to SQL";
168             } elsif (defined($p = $m{bash_class})) {
169 1         11 die "Currently cannot convert class pattern '$p' to SQL";
170             } elsif (defined($p = $m{literal})) {
171 29         159 push @res, $p;
172             }
173             }
174              
175 12         63 join "", @res;
176             }
177              
178             sub convert_wildcard_to_re {
179 28 100   28 1 68320 my $opts = ref $_[0] eq 'HASH' ? shift : {};
180 28         47 my $str = shift;
181              
182 28   100     91 my $opt_brace = $opts->{brace} // 1;
183 28   100     71 my $opt_dotglob = $opts->{dotglob} // 0;
184 28   100     62 my $opt_globstar = $opts->{globstar} // 0;
185 28   100     62 my $opt_ps = $opts->{path_separator} // '/';
186              
187 28 50       58 die "Please use a single character for path_separator" unless length($opt_ps) == 1;
188 28 100       61 my $q_ps =
    50          
189             $opt_ps eq '-' ? "\\-" :
190             $opt_ps eq '/' ? '/' :
191             quotemeta($opt_ps);
192              
193 28         47 my $re_not_ps = "[^$q_ps]";
194 28         32 my $re_not_dot = "[^.]";
195 28         47 my $re_not_dot_or_ps = "[^.$q_ps]";
196              
197 28         51 my @res;
198             my $p;
199 28         0 my $after_pathsep;
200 28         276 while ($str =~ /$RE_WILDCARD_BASH/g) {
201 60         404 my %m = %+;
202 60 100       267 if (defined($p = $m{bash_brace_content})) {
    100          
    100          
    100          
    100          
    50          
203             push @res, quotemeta($m{slashes_before_bash_brace}) if
204 2 50       18 $m{slashes_before_bash_brace};
205 2 100       6 if ($opt_brace) {
206 1         18 my @elems;
207 1         66 while ($p =~ /($re_bash_brace_element)(,|\z)/g) {
208 2         7 push @elems, $1;
209 2 100       10 last unless $2;
210             }
211             #use DD; dd \@elems;
212             push @res, "(?:", join("|", map {
213 1         2 convert_wildcard_to_re({
  2         12  
214             brace => 0,
215             dotglob => $opt_dotglob,
216             globstar => $opt_globstar,
217             }, $_)} @elems), ")";
218             } else {
219 1         3 push @res, quotemeta($m{bash_brace});
220             }
221              
222             } elsif (defined($p = $m{bash_joker})) {
223 32 100 66     100 if ($p eq '?') {
    100 66        
    50          
224 1         3 push @res, '.';
225             } elsif ($p eq '*' || $p eq '**' && !$opt_globstar) {
226 27 100 100     107 push @res, $opt_dotglob || (@res && !$after_pathsep) ?
227             "$re_not_ps*" : "$re_not_dot_or_ps$re_not_ps*";
228             } elsif ($p eq '**') { # and with 'globstar' option set
229 4 100 33     12 if ($opt_dotglob) {
    50          
230 2         5 push @res, '.*';
231             } elsif (@res && !$after_pathsep) {
232 0         0 push @res, "(?:$re_not_ps*)(?:$q_ps+$re_not_dot_or_ps$re_not_ps*)*";
233             } else {
234 2         8 push @res, "(?:$re_not_dot_or_ps$re_not_ps*)(?:$q_ps+$re_not_dot_or_ps$re_not_ps*)*";
235             }
236             }
237              
238             } elsif (defined($p = $m{literal_brace_single_element})) {
239 1         4 push @res, quotemeta($p);
240             } elsif (defined($p = $m{bash_class})) {
241             # XXX no need to escape some characters?
242 1         2 push @res, $p;
243             } elsif (defined($p = $m{sql_joker})) {
244 1         2 push @res, quotemeta($p);
245             } elsif (defined($p = $m{literal})) {
246 23         44 push @res, quotemeta($p);
247             }
248              
249 60   100     367 $after_pathsep = defined($m{literal}) && substr($m{literal}, -1) eq $opt_ps;
250             }
251              
252 28         155 join "", @res;
253             }
254              
255             1;
256             # ABSTRACT: Bash wildcard string routines
257              
258             __END__