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