1package Git::SVN::GlobSpec; 2use strict; 3use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); 4 5sub 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 59sub full_path { 60 my ($self, $path) = @_; 61 return (length $self->{left} ? "$self->{left}/" : '') . 62 $path . (length $self->{right} ? "/$self->{right}" : ''); 63} 64 651; 66