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__ |