git.oblomov.eu Git - git/blob - perl/Git/SVN/GlobSpec.pm

   1 package Git::SVN::GlobSpec;
   2 use strict;
   3 use warnings;
   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 wildcard directories " .
  12                                 "(e.g. '*' or '*/*/*') is supported: '$glob'\n";
  13         for my $part (split(m|/|, $glob)) {
  14                 if ($part =~ /\*/ && $part ne "*") {
  15                         die "Invalid pattern in '$glob': $part\n";
  16                 } elsif ($pattern_ok && $part =~ /[{}]/ &&
  17                          $part !~ /^\{[^{}]+\}/) {
  18                         die "Invalid pattern in '$glob': $part\n";
  19                 }
  20                 if ($part eq "*") {
  21                         die $die_msg if $state eq "right";
  22                         $state = "pattern";
  23                         push(@patterns, "[^/]*");
  24                 } elsif ($pattern_ok && $part =~ /^\{(.*)\}$/) {
  25                         die $die_msg if $state eq "right";
  26                         $state = "pattern";
  27                         my $p = quotemeta($1);
  28                         $p =~ s/\\,/|/g;
  29                         push(@patterns, "(?:$p)");
  30                 } else {
  31                         if ($state eq "left") {
  32                                 push(@left, $part);
  33                         } else {
  34                                 push(@right, $part);
  35                                 $state = "right";
  36                         }
  37                 }
  38         }
  39         my $depth = @patterns;
  40         if ($depth == 0) {
  41                 die "One '*' is needed in glob: '$glob'\n";
  42         }
  43         my $left = join('/', @left);
  44         my $right = join('/', @right);
  45         $re = join('/', @patterns);
  46         $re = join('\/',
  47                    grep(length, quotemeta($left),
  48                                 "($re)(?=/|\$)",
  49                                 quotemeta($right)));
  50         my $left_re = qr/^\/\Q$left\E(\/|$)/;
  51         bless { left => $left, right => $right, left_regex => $left_re,
  52                 regex => qr/$re/, glob => $glob, depth => $depth }, $class;
  53 }
  54
  55 sub full_path {
  56         my ($self, $path) = @_;
  57         return (length $self->{left} ? "$self->{left}/" : '') .
  58                $path . (length $self->{right} ? "/$self->{right}" : '');
  59 }
  60
  61 1;