File Coverage

File:blib/lib/App/FileSync/Ignore.pm
Coverage:93.2%

linestmtbrancondsubtimecode
1package App::FileSync::Ignore;
2
3# .gitignore-style exclusion patterns, compiled once per session and matched
4# against every path in the tree.
5
6
316
316
316
316
141429
270
4211
use App::FileSync::Platform;
7
8
316
316
316
316
508
216
2495
use strict;
9
316
316
316
316
414
247
5890
use warnings;
10
316
316
316
316
836
12181
635
use autodie qw(:all);
11
12
316
316
316
316
672885
3607
7887
use Readonly;
13
316
316
316
316
1102
55616
1066
use Sub::Private { mode => 'enforce' };
14
15
316
316
316
316
30324
273
5635
use App::FileSync::Args qw(named);
16
17
316
316
316
316
535
251
755
use version; our $VERSION = version->declare('0.001.1');
18
19# A line that is blank or a comment ("# note", or a lone "#").  "#*#" is a
20# pattern (Emacs autosave files), as .gitignore allows with a backslash.
21Readonly my $COMMENT => qr/\A\s*(?:#\s|#\z|\z)/;
22
23=encoding utf8
24
25 - 89
=head1 NAME

App::FileSync::Ignore - .gitignore-style path exclusion

=head1 SYNOPSIS

        my $ignore = App::FileSync::Ignore->new(patterns => [ '*.tmp', '!keep.tmp', 'build/' ]);
        print "skip\n" if $ignore->match('src/a.tmp');

=head1 DESCRIPTION

Patterns follow .gitignore: C<*> matches within one component, C<**/>
matches any number of directories, C<?> one character, a leading C<!>
re-includes, a leading C</> anchors at the root, and a pattern without a slash
matches at any depth.  Later patterns win.  A path inside an ignored directory
is ignored.

=head1 METHODS

=head2 new

Purpose: compile a list of patterns.

Args: C<patterns> (arrayref of strings; undefined entries, blanks and comments
are skipped), C<case_insensitive> (boolean).

Returns: an C<App::FileSync::Ignore> object.

Side Effects: none.  The caller's list is not modified.

Usage:

        my $ignore = App::FileSync::Ignore->new(patterns => $config->{ignore});

=head3 EXAMPLE

        my $ignore = App::FileSync::Ignore->new(
                patterns         => [ '*.bak', '# editor files', '*~' ],
                case_insensitive => 1,
        );

=head3 API SPECIFICATION

=head4 INPUT

        {
                patterns         => { type => 'arrayref', optional => 1 },
                case_insensitive => { type => 'boolean', optional => 1 },
        }

=head4 OUTPUT

        { type => 'object', isa => 'App::FileSync::Ignore' }

=head3 MESSAGES

        Key            Meaning                     Resolution
        args.invalid   patterns is not a list      pass an arrayref

=head3 FORMAL SPECIFICATION

        new(ps, ci) = ⟨compiled ↦ ⟨(neg(p), re(p, ci)) | p ← ps, ¬ comment(p)⟩⟩
        ps' = ps

=cut
90
91sub new {
92
582
582
252804
        my $class = shift;
93
582
3768
        my $args = named(\@_, {
94                patterns         => { type => 'arrayref', optional => 1 },
95                case_insensitive => { type => 'boolean', optional => 1 },
96        }, 'Ignore->new');
97
98
582
1056
        my @compiled;
99
582
582
50
599
1343
        for my $given (@{ $args->{patterns} || [] }) {
100
7482
50
6291
                next unless defined $given;
101
7482
100
8861
                next if $given =~ $COMMENT;
102
103                # Work on a copy: the list usually belongs to the repo config, which
104                # the server sends on to the client after building this object.
105
7480
22050
                my $raw = $given;
106
7480
100
6280
                my $negated = $raw =~ s/\A!// ? 1 : 0;
107
7480
4876
                $raw =~ s/\A\s+//;
108
7480
5207
                $raw =~ s/\s+\z//;
109
7480
50
5513
                next unless length $raw;
110
111
7480
6469
                my $re = _glob_to_re($raw);
112                push @compiled, {
113                        negated => $negated,
114
7480
100
59982
                        re      => $args->{case_insensitive} ? qr/\A$re\z/i : qr/\A$re\z/,
115                };
116        }
117
118
582
4094
        return bless { compiled => \@compiled }, $class;
119}
120
121 - 171
=head2 match

Purpose: decide whether a path is excluded.

Args: C<$path>, relative and C</>-separated.

Returns: 1 when the path, or any directory above it, is ignored; otherwise 0.

Side Effects: none.

Usage:

        next if $ignore->match($relative_path);

=head3 EXAMPLE

        my $ignore = App::FileSync::Ignore->new(patterns => [ 'build' ]);
        print $ignore->match('build/out/a.o'), "\n";       # 1

=head3 API SPECIFICATION

=head4 INPUT

        [
                { name => 'self', type => 'object' },
                { name => 'path', type => 'string', optional => 1 },
        ]

=head4 OUTPUT

        { type => 'integer', min => 0, max => 1 }

=head3 MESSAGES

None.  Called once per path, so arguments are checked by hand.

=head3 FORMAL SPECIFICATION

        ignored(c) ⇔ last ⟨ ¬neg(p) | p ← compiled, c ∈ re(p) ⟩ = true
        match(path) ⇔ ∃ a : {path} ∪ ancestors(path) • ignored(a)

=head3 PSEUDOCODE

        candidates := path, then each directory above it
        for each candidate:
                state := not ignored
                for each pattern in order: if it matches, state := not negated
                if state is ignored: return 1
        return 0

=cut
172
173sub match {
174
1531
1531
1409
        my ($self, $path) = @_;
175
176
1531
50
33
2512
        return 0 unless defined $path && length $path;
177
178        # A path inside an ignored directory is ignored too, even if the caller
179        # only asks about the file (the scanner prunes at the directory, but this
180        # keeps the answer correct for every caller).
181
1531
1341
        my @candidates = ($path);
182
1531
1045
        my $prefix = $path;
183
1531
1892
        push @candidates, $prefix while $prefix =~ s{/[^/]+\z}{};
184
185
1531
1216
        for my $candidate (@candidates) {
186
1643
1005
                my $ignored = 0;
187
1643
1643
945
1427
                for my $pattern (@{ $self->{compiled} }) {
188
20548
100
100
22335
                        $ignored = $pattern->{negated} ? 0 : 1 if $candidate =~ $pattern->{re};
189                }
190
1643
100
1931
                return 1 if $ignored;
191        }
192
193
1333
1794
        return 0;
194}
195
196# _glob_to_re
197# Purpose:     translate one .gitignore-style glob into a regex body.
198# Entry:       $pattern has had its "!" and surrounding blanks removed.
199# Exit:        returns the regex source (not anchored; new() anchors it).
200# Side effects: none.  Hand-written rather than Text::Glob, which has no
201#              "**" and no "slash-less pattern matches at any depth" rule.
202sub _glob_to_re :Private {
203        my ($pattern) = @_;
204
205        # A leading slash anchors; a trailing one (.gitignore's directory marker)
206        # does not, so "build/" matches "build" at any depth as git users expect.
207        $pattern =~ s{/\z}{};
208        my $anchored = $pattern =~ s{\A/}{} ? 1 : 0;
209        my $has_slash = $pattern =~ m{/} ? 1 : 0;
210
211        # Translate token by token: "**/" any directories, "**" anything, "*"
212        # within a component, "?" one character, everything else literally.
213        my $re = '';
214        while (length $pattern) {
215                if ($pattern =~ s{\A\*\*/}{}) {
216                        $re .= '(?:.*/)?';
217                } elsif ($pattern =~ s{\A\*\*}{}) {
218                        $re .= '.*';
219                } elsif ($pattern =~ s{\A\*}{}) {
220                        $re .= '[^/]*';
221                } elsif ($pattern =~ s{\A\?}{}) {
222                        $re .= '[^/]';
223                } else {
224                        $re .= quotemeta(substr($pattern, 0, 1, ''));
225                }
226        }
227
228        # A pattern without a slash matches any path segment, like .gitignore.
229        return ($anchored || $has_slash) ? $re : "(?:.*/)?$re";
230
316
316
316
316
129798
265
4220
}
231
2321;
233