File Coverage

blib/lib/Code/TidyAll/Util/Zglob.pm
Criterion Covered Total %
statement 41 52 78.8
branch 22 50 44.0
condition 12 30 40.0
subroutine 7 7 100.0
pod 0 3 0.0
total 82 142 57.7


line stmt bran cond sub pod time code
1             # This is a copy of Text::Glob, modified to support "**/"
2             #
3              
4             use strict;
5 27     27   163 use warnings;
  27         53  
  27         687  
6 27     27   120  
  27         43  
  27         950  
7             our $VERSION = '0.82';
8              
9             use Exporter qw(import);
10 27     27   139  
  27         62  
  27         1864  
11             our @EXPORT_OK = qw( zglobs_to_regex zglob_to_regex );
12              
13             our $strict_leading_dot = 1;
14             our $strict_wildcard_slash = 1;
15              
16             use constant debug => 0;
17 27     27   173  
  27         46  
  27         15424  
18             my @globs = @_;
19             return @globs
20 132     132 0 4654 ? do {
21             my $re = join( '|', map { "(?:" . zglob_to_regex($_) . ")" } @globs );
22 132 100       1287 qr/$re/;
23 61         114 }
  61         141  
24 61         1852 : qr/(?!)/;
25             }
26              
27             my $glob = shift;
28             my $regex = zglob_to_regex_string($glob);
29             return qr/^$regex$/;
30 64     64 0 6865 }
31 64         166  
32 64         1634 my $glob = shift;
33             my ( $regex, $in_curlies, $escaping );
34             local $_;
35             my $first_byte = 1;
36 64     64 0 95 $glob =~ s/\*\*\//\cZ/g; # convert **/ to single character
37 64         90 for ( $glob =~ m/(.)/gs ) {
38 64         86 if ($first_byte) {
39 64         86 if ($strict_leading_dot) {
40 64         174 $regex .= '(?=[^\.])' unless $_ eq '.';
41 64         394 }
42 400 100       576 $first_byte = 0;
43 81 50       157 }
44 81 50       218 if ( $_ eq '/' ) {
45             $first_byte = 1;
46 81         140 }
47             if ( $_ eq '.'
48 400 100       619 || $_ eq '('
49 17         25 || $_ eq ')'
50             || $_ eq '|'
51 400 100 66     4105 || $_ eq '+'
    100 66        
    100 33        
    50 33        
    50 33        
    50 33        
    50 33        
    50 33        
      33        
      33        
52             || $_ eq '^'
53             || $_ eq '$'
54             || $_ eq '@'
55             || $_ eq '%' ) {
56             $regex .= "\\$_";
57             }
58             elsif ( $_ eq "\cZ" ) { # handle **/ - if escaping, only escape first *
59             $regex
60 19         30 .= $escaping
61             ? ( "\\*" . ( $strict_wildcard_slash ? "[^/]*" : ".*" ) . "/" )
62             : ".*";
63 23 0       42 }
    50          
64             elsif ( $_ eq '*' ) {
65             $regex
66             .= $escaping ? "\\*"
67             : $strict_wildcard_slash ? "[^/]*"
68             : ".*";
69 64 50       183 }
    50          
70             elsif ( $_ eq '?' ) {
71             $regex
72             .= $escaping ? "\\?"
73             : $strict_wildcard_slash ? "[^/]"
74             : ".";
75 0 0       0 }
    0          
76             elsif ( $_ eq '{' ) {
77             $regex .= $escaping ? "\\{" : "(";
78             ++$in_curlies unless $escaping;
79             }
80             elsif ( $_ eq '}' && $in_curlies ) {
81 0 0       0 $regex .= $escaping ? "}" : ")";
82 0 0       0 --$in_curlies unless $escaping;
83             }
84             elsif ( $_ eq ',' && $in_curlies ) {
85 0 0       0 $regex .= $escaping ? "," : "|";
86 0 0       0 }
87             elsif ( $_ eq "\\" ) {
88             if ($escaping) {
89 0 0       0 $regex .= "\\\\";
90             $escaping = 0;
91             }
92 0 0       0 else {
93 0         0 $escaping = 1;
94 0         0 }
95             next;
96             }
97 0         0 else {
98             $regex .= $_;
99 0         0 $escaping = 0;
100             }
101             $escaping = 0;
102 294         326 }
103 294         322 print "# $glob $regex\n" if debug;
104              
105 400         496 return $regex;
106             }
107 64         112  
108             1;
109 64         162  
110             # ABSTRACT: Test::Glob hacked up to support "**/*"
111              
112              
113             =pod
114              
115             =encoding UTF-8
116              
117             =head1 NAME
118              
119             Code::TidyAll::Util::Zglob - Test::Glob hacked up to support "**/*"
120              
121             =head1 VERSION
122              
123             version 0.82
124              
125             =head1 SUPPORT
126              
127             Bugs may be submitted at L<https://github.com/houseabsolute/perl-code-tidyall/issues>.
128              
129             =head1 SOURCE
130              
131             The source code repository for Code-TidyAll can be found at L<https://github.com/houseabsolute/perl-code-tidyall>.
132              
133             =head1 AUTHORS
134              
135             =over 4
136              
137             =item *
138              
139             Jonathan Swartz <swartz@pobox.com>
140              
141             =item *
142              
143             Dave Rolsky <autarch@urth.org>
144              
145             =back
146              
147             =head1 COPYRIGHT AND LICENSE
148              
149             This software is copyright (c) 2011 - 2022 by Jonathan Swartz.
150              
151             This is free software; you can redistribute it and/or modify it under
152             the same terms as the Perl 5 programming language system itself.
153              
154             The full text of the license can be found in the
155             F<LICENSE> file included with this distribution.
156              
157             =cut