Merge pull request #510 from rjbs/indexer-perl-tests

indexer tests: more tests! mostly about indexing perl
andk · May 19, 2024 · 9011400 · 9011400
2 parents 3dd9988 + 2e9327b
commit 9011400
Show file tree

Hide file tree

Showing 6 changed files with 520 additions and 158 deletions.
diff --git a/t/lib/PAUSE/TestPAUSE.pm b/t/lib/PAUSE/TestPAUSE.pm
@@ -2,6 +2,7 @@ package PAUSE::TestPAUSE;
 use Moose;
 use MooseX::StrictConstructor;
 
+use v5.36.0;
 use autodie;
 
 use DBI;
@@ -13,6 +14,7 @@ use File::pushd;
 use File::Temp ();
 use File::Which;
 use Path::Class;
+use Process::Status;
 
 # This one, we don't expect to be used.  In a weird world, we'd mark it fatal
 # or something so we could say "nothing should log outside of test code."
@@ -235,6 +237,28 @@ sub upload_author_file {
   return File::Spec->catfile($author_dir, $file);
 }
 
+sub upload_author_garbage {
+  my ($self, $author, $file) = @_;
+
+  $author = uc $author;
+  my $cpan_root  = File::Spec->catdir($self->tmpdir, 'cpan');
+  my $author_dir = File::Spec->catdir(
+    $cpan_root,
+    qw(authors id),
+    (substr $author, 0, 1),
+    (substr $author, 0, 2),
+    $author,
+  );
+
+  make_path( $author_dir );
+  my $target = File::Spec->catfile($author_dir, $file);
+  system('dd', 'if=/dev/random', "of=$target", "count=20", "status=none"); # write 20k
+
+  Process::Status->assert_ok("dd from /dev/random to $target");
+
+  return $target;
+}
+
 has pause_config_overrides => (
   is  => 'ro',
   isa => 'HashRef',
@@ -349,100 +373,54 @@ sub test_reindex {
 
     die "stray mail in test mail trap before reindex" if @stray_mail;
 
+    my $existing_log_events = $self->logger->events->@*;
+
     if ($arg->{pick}) {
       my $dbh = PAUSE::dbh();
       $dbh->do("DELETE FROM distmtimes WHERE dist = ?", undef, $_)
         for @{ $arg->{pick} };
     }
 
+    my sub filestate ($file) {
+      return ';;' unless -e $file;
+      my @stat = stat $file;
+      return join q{;}, @stat[0,1,7]; # dev, ino, size
+    }
+
+    my $package_file = $self->tmpdir->file(qw(cpan modules 02packages.details.txt.gz));
+
+    my $old_package_state = filestate($package_file);
+
     PAUSE::mldistwatch->new({
       sleep => 0,
       ($arg->{pick} ? (pick => $arg->{pick}) : ()),
     })->reindex;
 
     $arg->{after}->($self->tmpdir) if $arg->{after};
 
+    # The first $existing_log_events were already there.  We only care about
+    # ones added during the indexer run.
+    my @log_events = $self->logger->events->@*;
+    splice @log_events, 0, $existing_log_events;
+
     my @deliveries = Email::Sender::Simple->default_transport->deliveries;
 
     Email::Sender::Simple->default_transport->clear_deliveries;
 
+    my $new_package_state = filestate($package_file);
+
     return PAUSE::TestPAUSE::Result->new({
       tmpdir => $self->tmpdir,
       config_overrides => $self->pause_config_overrides,
       authen_db_file   => File::Spec->catfile($self->db_root, 'authen.sqlite'),
       mod_db_file      => File::Spec->catfile($self->db_root, 'mod.sqlite'),
       deliveries       => \@deliveries,
+      log_events       => \@log_events,
+      updated_02packages => $old_package_state ne $new_package_state,
     });
   });
 }
 
-has _file_index => (
-  is      => 'ro',
-  default => sub {  {}  },
-);
-
-sub file_updated_ok {
-  my ($self, $filename, $desc) = @_;
-  $desc = defined $desc ? "$desc: " : q{};
-
-  local $Test::Builder::Level = $Test::Builder::Level + 1;
-
-  my $tmpdir = $self->tmpdir . "";
-  my $prettyname = $filename =~ s/\Q$tmpdir/\${TEST}/r;
-
-  unless (-e $filename) {
-    return Test::More::fail("$desc$prettyname not updated");
-  }
-
-  my ($dev, $ino) = stat $filename;
-
-  my $old = $self->_file_index->{ $filename };
-
-  unless (defined $old) {
-    $self->_file_index->{$filename} = "$dev,$ino";
-    return Test::More::pass("$desc$prettyname updated (created)");
-  }
-
-  my $ok = Test::More::ok(
-    $old ne "$dev,$ino",
-    "$desc$prettyname updated",
-  );
-
-  $self->_file_index->{$filename} = "$dev,$ino";
-  return $ok;
-}
-
-sub file_not_updated_ok {
-  my ($self, $filename, $desc) = @_;
-  $desc = defined $desc ? "$desc: " : q{};
-
-  local $Test::Builder::Level = $Test::Builder::Level + 1;
-
-  my $old = $self->_file_index->{ $filename };
-
-  my $tmpdir = $self->tmpdir . "";
-  my $prettyname = $filename =~ s/\Q$tmpdir/\${TEST}/r;
-
-  unless (-e $filename) {
-    return Test::More::fail("$desc$prettyname deleted") if $old;
-    return Test::More::pass("$desc$prettyname not created (thus not updated)");
-  }
-
-  my ($dev, $ino) = stat $filename;
-
-  unless (defined $old) {
-    $self->_file_index->{$filename} = "$dev,$ino";
-    return Test::More::fail("$desc$prettyname updated (created)");
-  }
-
-  my $ok = Test::More::ok(
-    $old eq "$dev,$ino",
-    "$desc$prettyname not updated",
-  );
-
-  return $ok;
-}
-
 sub run_shell {
   my ($self) = @_;
 

diff --git a/t/lib/PAUSE/TestPAUSE/Result.pm b/t/lib/PAUSE/TestPAUSE/Result.pm
@@ -2,6 +2,8 @@ package PAUSE::TestPAUSE::Result;
 use Moose;
 use MooseX::StrictConstructor;
 
+use v5.36.0;
+
 use DBI;
 use Parse::CPAN::Packages;
 use Test::Deep qw(cmp_deeply superhashof methods);
@@ -112,7 +114,7 @@ sub perm_list_ok {
                  ->file(qw(06perms.txt.gz));
 
   our $GZIP = $PAUSE::Config->{GZIP_PATH};
-  open my $fh, "$GZIP --stdout --uncompress $index_06|"
+  open my $fh, "-|", "$GZIP --stdout --uncompress $index_06"
     or die "can't open $index_06 for reading with gip: $!";
 
   my (@header, @data);
@@ -130,6 +132,8 @@ sub perm_list_ok {
     }
   }
 
+  close($fh) or die "error reading $index_06: $!";
+
   is_deeply(\%permissions, $want, "permissions look correct in 06perms")
     or diag explain(\%permissions);
 }
@@ -172,4 +176,42 @@ sub email_ok {
   }
 }
 
+has updated_02packages => (
+  is  => 'ro',
+  isa => 'Bool',
+  required => 1,
+);
+
+sub assert_index_updated ($self, $desc = "02packages was changed") {
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+  ok($self->updated_02packages, $desc);
+}
+
+sub assert_index_not_updated ($self, $desc = "02packages was not changed") {
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+  ok(!$self->updated_02packages, $desc);
+}
+
+has log_events => (
+  isa => 'ArrayRef',
+  required => 1,
+  traits   => [ 'Array' ],
+  handles  => { log_events => 'elements' },
+);
+
+sub logged_event_like ($self, $qr, $desc = "found matching log line") {
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+  ok(
+    (grep {; $_->{message} =~ $qr } $self->log_events),
+    $desc,
+  );
+}
+
+sub diag_log_messages ($self) {
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+  diag($_->{message}) for $self->log_events;
+}
+
 1;
diff --git a/t/mldistwatch-big.t b/t/mldistwatch-big.t
@@ -17,17 +17,7 @@ subtest "first indexing" => sub {
 
   my $result = $pause->test_reindex;
 
-  $pause->file_updated_ok(
-    $result->tmpdir
-           ->file(qw(cpan modules 02packages.details.txt.gz)),
-    "our indexer indexed",
-  );
-
-  $pause->file_updated_ok(
-    $result->tmpdir
-           ->file(qw(cpan modules 03modlist.data.gz)),
-    "our indexer indexed",
-  );
+  $result->assert_index_updated;
 
   $result->package_list_ok(
     [
@@ -97,11 +87,7 @@ for my $uploader (qw(FCOME CMAINT)) {
     {
       my $result = $pause->test_reindex;
 
-      $pause->file_updated_ok(
-        $result->tmpdir
-               ->file(qw(cpan modules 02packages.details.txt.gz)),
-        "our indexer indexed",
-      );
+      $result->assert_index_updated;
 
       $result->package_list_ok(
         [
@@ -222,11 +208,7 @@ subtest "case mismatch, authorized for original" => sub {
 
   my $result = $pause->test_reindex;
 
-  $pause->file_updated_ok(
-    $result->tmpdir
-           ->file(qw(cpan modules 02packages.details.txt.gz)),
-    "our indexer indexed",
-  );
+  $result->assert_index_updated;
 
   $result->package_list_ok(
     [

diff --git a/t/mldistwatch-db.t b/t/mldistwatch-db.t
@@ -57,10 +57,7 @@ subtest "retry indexing on db failure, only three times" => sub {
 
   is($x, 3, "we tried three times, and no more");
 
-  $pause->file_not_updated_ok(
-    $result->tmpdir->file(qw(cpan modules 02packages.details.txt.gz)),
-    "did not reindex",
-  );
+  $result->assert_index_not_updated;
 
   $result->email_ok(
     [