| 1 | package Git::SVN::GlobSpec; |
| 2 | use strict; |
| 3 | use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); |
| 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 wildcards " . |
| 12 | "(e.g. '*' or '*/*/*') is supported: $glob\n"; |
| 13 | for my $part (split(m|/|, $glob)) { |
| 14 | if ($pattern_ok && $part =~ /[{}]/ && |
| 15 | $part !~ /^\{[^{}]+\}/) { |
| 16 | die "Invalid pattern in '$glob': $part\n"; |
| 17 | } |
| 18 | my $nstars = $part =~ tr/*//; |
| 19 | if ($nstars > 1) { |
| 20 | die "Only one '*' is allowed in a pattern: '$part'\n"; |
| 21 | } |
| 22 | if ($part =~ /(.*)\*(.*)/) { |
| 23 | die $die_msg if $state eq "right"; |
| 24 | my ($l, $r) = ($1, $2); |
| 25 | $state = "pattern"; |
| 26 | my $pat = quotemeta($l) . '[^/]*' . quotemeta($r); |
| 27 | push(@patterns, $pat); |
| 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('\/', |
| 51 | grep(length, quotemeta($left), |
| 52 | "($re)(?=/|\$)", |
| 53 | quotemeta($right))); |
| 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; |