]>
Commit | Line | Data |
---|---|---|
3d9be15f MS |
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"; | |
62335bbb EW |
11 | my $die_msg = "Only one set of wildcards " . |
12 | "(e.g. '*' or '*/*/*') is supported: $glob\n"; | |
3d9be15f | 13 | for my $part (split(m|/|, $glob)) { |
e4e5dd94 | 14 | if ($pattern_ok && $part =~ /[{}]/ && |
3d9be15f MS |
15 | $part !~ /^\{[^{}]+\}/) { |
16 | die "Invalid pattern in '$glob': $part\n"; | |
17 | } | |
e4e5dd94 VL |
18 | my $nstars = $part =~ tr/*//; |
19 | if ($nstars > 1) { | |
20 | die "Only one '*' is allowed in a pattern: '$part'\n"; | |
21 | } | |
22 | if ($part =~ /(.*)\*(.*)/) { | |
3d9be15f | 23 | die $die_msg if $state eq "right"; |
e4e5dd94 | 24 | my ($l, $r) = ($1, $2); |
3d9be15f | 25 | $state = "pattern"; |
e4e5dd94 VL |
26 | my $pat = quotemeta($l) . '[^/]*' . quotemeta($r); |
27 | push(@patterns, $pat); | |
3d9be15f MS |
28 | } elsif ($pattern_ok && $part =~ /^\{(.*)\}$/) { |
29 | die $die_msg if $state eq "right"; | |
30 | $state = "pattern"; | |
31 | my $p = quotemeta($1); | |
32 | $p =~ s/\\,/|/g; | |
33 | push(@patterns, "(?:$p)"); | |
34 | } else { | |
35 | if ($state eq "left") { | |
36 | push(@left, $part); | |
37 | } else { | |
38 | push(@right, $part); | |
39 | $state = "right"; | |
40 | } | |
41 | } | |
42 | } | |
43 | my $depth = @patterns; | |
44 | if ($depth == 0) { | |
45 | die "One '*' is needed in glob: '$glob'\n"; | |
46 | } | |
47 | my $left = join('/', @left); | |
48 | my $right = join('/', @right); | |
49 | $re = join('/', @patterns); | |
50 | $re = join('\/', | |
9478b119 AR |
51 | grep(length, quotemeta($left), |
52 | "($re)(?=/|\$)", | |
53 | quotemeta($right))); | |
3d9be15f MS |
54 | my $left_re = qr/^\/\Q$left\E(\/|$)/; |
55 | bless { left => $left, right => $right, left_regex => $left_re, | |
56 | regex => qr/$re/, glob => $glob, depth => $depth }, $class; | |
57 | } | |
58 | ||
59 | sub full_path { | |
60 | my ($self, $path) = @_; | |
61 | return (length $self->{left} ? "$self->{left}/" : '') . | |
62 | $path . (length $self->{right} ? "/$self->{right}" : ''); | |
63 | } | |
64 | ||
65 | 1; |