Merge branch 'mn/doc-pack-heu-remove-dead-pastebin'
[git] / perl / Git / SVN / GlobSpec.pm
1 package Git::SVN::GlobSpec;
2 use strict;
3 use warnings;
4
5 sub new {
6         my ($class, $glob, $pattern_ok) = @_;
7         my $re = $glob;
8         $re =~ s!/+$!!g; # no need for trailing slashes
9         my (@left, @right, @patterns);
10         my $state = "left";
11         my $die_msg = "Only one set of wildcard directories " .
12                                 "(e.g. '*' or '*/*/*') is supported: '$glob'\n";
13         for my $part (split(m|/|, $glob)) {
14                 if ($part =~ /\*/ && $part ne "*") {
15                         die "Invalid pattern in '$glob': $part\n";
16                 } elsif ($pattern_ok && $part =~ /[{}]/ &&
17                          $part !~ /^\{[^{}]+\}/) {
18                         die "Invalid pattern in '$glob': $part\n";
19                 }
20                 if ($part eq "*") {
21                         die $die_msg if $state eq "right";
22                         $state = "pattern";
23                         push(@patterns, "[^/]*");
24                 } elsif ($pattern_ok && $part =~ /^\{(.*)\}$/) {
25                         die $die_msg if $state eq "right";
26                         $state = "pattern";
27                         my $p = quotemeta($1);
28                         $p =~ s/\\,/|/g;
29                         push(@patterns, "(?:$p)");
30                 } else {
31                         if ($state eq "left") {
32                                 push(@left, $part);
33                         } else {
34                                 push(@right, $part);
35                                 $state = "right";
36                         }
37                 }
38         }
39         my $depth = @patterns;
40         if ($depth == 0) {
41                 die "One '*' is needed in glob: '$glob'\n";
42         }
43         my $left = join('/', @left);
44         my $right = join('/', @right);
45         $re = join('/', @patterns);
46         $re = join('\/',
47                    grep(length, quotemeta($left),
48                                 "($re)(?=/|\$)",
49                                 quotemeta($right)));
50         my $left_re = qr/^\/\Q$left\E(\/|$)/;
51         bless { left => $left, right => $right, left_regex => $left_re,
52                 regex => qr/$re/, glob => $glob, depth => $depth }, $class;
53 }
54
55 sub full_path {
56         my ($self, $path) = @_;
57         return (length $self->{left} ? "$self->{left}/" : '') .
58                $path . (length $self->{right} ? "/$self->{right}" : '');
59 }
60
61 1;