|
|
|
|
package Git::IndexInfo;
|
|
|
|
|
use strict;
|
perl: check for perl warnings while running tests
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>
4 years ago
|
|
|
use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : ();
|
|
|
|
|
use Git qw/command_input_pipe command_close_pipe/;
|
|
|
|
|
|
|
|
|
|
sub new {
|
|
|
|
|
my ($class) = @_;
|
|
|
|
|
my $hash_algo = Git::config('extensions.objectformat') || 'sha1';
|
|
|
|
|
my ($gui, $ctx) = command_input_pipe(qw/update-index -z --index-info/);
|
|
|
|
|
bless { gui => $gui, ctx => $ctx, nr => 0, hash_algo => $hash_algo}, $class;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
sub remove {
|
|
|
|
|
my ($self, $path) = @_;
|
|
|
|
|
my $length = $self->{hash_algo} eq 'sha256' ? 64 : 40;
|
|
|
|
|
if (print { $self->{gui} } '0 ', 0 x $length, "\t", $path, "\0") {
|
|
|
|
|
return ++$self->{nr};
|
|
|
|
|
}
|
|
|
|
|
undef;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
sub update {
|
|
|
|
|
my ($self, $mode, $hash, $path) = @_;
|
|
|
|
|
if (print { $self->{gui} } $mode, ' ', $hash, "\t", $path, "\0") {
|
|
|
|
|
return ++$self->{nr};
|
|
|
|
|
}
|
|
|
|
|
undef;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
sub DESTROY {
|
|
|
|
|
my ($self) = @_;
|
|
|
|
|
command_close_pipe($self->{gui}, $self->{ctx});
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
1;
|
