Andrew's git - gitweb.git/blob - perl/Git/SVN/GlobSpec.pm

   1package Git::SVN::GlobSpec;
   2use strict;
   3use warnings;
   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;