mirror of
https://github.com/git/git.git
synced 2024-05-05 08:16:11 +02:00
5338ed2b26
We set "use warnings" in most of our perl code to catch problems. But as the name implies, warnings just emit a message to stderr and don't otherwise affect the program. So our tests are quite likely to miss that warnings are being spewed, as most of them do not look at stderr. We could ask perl to make all warnings fatal, but this is likely annoying for non-developers, who would rather have a running program with a warning than something that refuses to work at all. So instead, let's teach the perl code to respect an environment variable (GIT_PERL_FATAL_WARNINGS) to increase the severity of the warnings. This can be set for day-to-day running if people want to be really pedantic, but the primary use is to trigger it within the test suite. We could also trigger that for every test run, but likewise even the tests failing may be annoying to distro builders, etc (just as -Werror would be for compiling C code). So we'll tie it to a special test-mode variable (GIT_TEST_PERL_FATAL_WARNINGS) that can be set in the environment or as a Makefile knob, and we'll automatically turn the knob when DEVELOPER=1 is set. That should give developers and CI the more careful view without disrupting normal users or packagers. Note that the mapping from the GIT_TEST_* form to the GIT_* form in test-lib.sh is necessary even if they had the same name: the perl scripts need it to be normalized to a perl truth value, and we also have to make sure it's exported (we might have gotten it from the environment, but we might also have gotten it from GIT-BUILD-OPTIONS directly). Signed-off-by: Jeff King <peff@peff.net> Signed-off-by: Junio C Hamano <gitster@pobox.com>
66 lines
1.8 KiB
Perl
66 lines
1.8 KiB
Perl
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;
|