| package Git::SVN::GlobSpec; |
| use strict; |
| use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); |
| |
| sub new { |
| my ($class, $glob, $pattern_ok) = @_; |
| my $re = $glob; |
| $re =~ s!/+$!!g; # no need for trailing slashes |
| my (@left, @right, @patterns); |
| my $state = "left"; |
| my $die_msg = "Only one set of wildcards " . |
| "(e.g. '*' or '*/*/*') is supported: $glob\n"; |
| for my $part (split(m|/|, $glob)) { |
| if ($pattern_ok && $part =~ /[{}]/ && |
| $part !~ /^\{[^{}]+\}/) { |
| die "Invalid pattern in '$glob': $part\n"; |
| } |
| my $nstars = $part =~ tr/*//; |
| if ($nstars > 1) { |
| die "Only one '*' is allowed in a pattern: '$part'\n"; |
| } |
| if ($part =~ /(.*)\*(.*)/) { |
| die $die_msg if $state eq "right"; |
| my ($l, $r) = ($1, $2); |
| $state = "pattern"; |
| my $pat = quotemeta($l) . '[^/]*' . quotemeta($r); |
| push(@patterns, $pat); |
| } elsif ($pattern_ok && $part =~ /^\{(.*)\}$/) { |
| die $die_msg if $state eq "right"; |
| $state = "pattern"; |
| my $p = quotemeta($1); |
| $p =~ s/\\,/|/g; |
| push(@patterns, "(?:$p)"); |
| } else { |
| if ($state eq "left") { |
| push(@left, $part); |
| } else { |
| push(@right, $part); |
| $state = "right"; |
| } |
| } |
| } |
| my $depth = @patterns; |
| if ($depth == 0) { |
| die "One '*' is needed in glob: '$glob'\n"; |
| } |
| my $left = join('/', @left); |
| my $right = join('/', @right); |
| $re = join('/', @patterns); |
| $re = join('\/', |
| grep(length, quotemeta($left), |
| "($re)(?=/|\$)", |
| quotemeta($right))); |
| my $left_re = qr/^\/\Q$left\E(\/|$)/; |
| bless { left => $left, right => $right, left_regex => $left_re, |
| regex => qr/$re/, glob => $glob, depth => $depth }, $class; |
| } |
| |
| sub full_path { |
| my ($self, $path) = @_; |
| return (length $self->{left} ? "$self->{left}/" : '') . |
| $path . (length $self->{right} ? "/$self->{right}" : ''); |
| } |
| |
| 1; |