From f410511228c1d5216c11841b8d564a37d51296da Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 15:00:18 -0400 Subject: [PATCH 01/17] tests: add assert_index_updated and assert_index_not_updated The previous method for checking this was generic, which is nice, but sort of verbose to use. Worse, though, I don't think it was reliable. That code, ->file_updated_ok and ->file_not_updated_ok, worked by keeping a cache of file stats -- but it didn't precompute those stats, it computed them on demand. So given this program: $pause = PAUSE::TestPause->new; do_stuff(); my $r1 = $pause->test_reindex; do_other_stuff(); $pause->file_updated_ok("A"); my $r2 = $pause->test_reindex; do_more_stuff(); my $r3 = $pause->test_reindex; Calling `->file_updated_ok("A")` at the end would test since the previous call. Calling `->file_updated_ok("B")` at the end would test starting from nothing. In reality, we only use this method for tracking 02packages, so I've added specific tracking of that file, with the check put onto the Result object, considering only what changed in the `test_reindex` call that created that Result. --- t/lib/PAUSE/TestPAUSE.pm | 14 ++++++++++++ t/lib/PAUSE/TestPAUSE/Result.pm | 22 +++++++++++++++++- t/mldistwatch-big.t | 24 +++----------------- t/mldistwatch-db.t | 5 +---- t/mldistwatch-misc.t | 40 +++++++++++++++------------------ 5 files changed, 57 insertions(+), 48 deletions(-) diff --git a/t/lib/PAUSE/TestPAUSE.pm b/t/lib/PAUSE/TestPAUSE.pm index e423f6bff..8419aa00c 100644 --- 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; @@ -355,6 +356,16 @@ sub test_reindex { 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}) : ()), @@ -362,6 +373,8 @@ sub test_reindex { $arg->{after}->($self->tmpdir) if $arg->{after}; + my $new_package_state = filestate($package_file); + my @deliveries = Email::Sender::Simple->default_transport->deliveries; Email::Sender::Simple->default_transport->clear_deliveries; @@ -372,6 +385,7 @@ sub test_reindex { authen_db_file => File::Spec->catfile($self->db_root, 'authen.sqlite'), mod_db_file => File::Spec->catfile($self->db_root, 'mod.sqlite'), deliveries => \@deliveries, + updated_02packages => $old_package_state ne $new_package_state, }); }); } diff --git a/t/lib/PAUSE/TestPAUSE/Result.pm b/t/lib/PAUSE/TestPAUSE/Result.pm index 999382fb3..70cc24b5b 100644 --- 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,20 @@ 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); +} + 1; diff --git a/t/mldistwatch-big.t b/t/mldistwatch-big.t index c468d9cdb..753b160fd 100644 --- 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 index bc85f45eb..e99f0d291 100644 --- 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( [ diff --git a/t/mldistwatch-misc.t b/t/mldistwatch-misc.t index f75a4d290..ff88408d0 100644 --- a/t/mldistwatch-misc.t +++ b/t/mldistwatch-misc.t @@ -17,10 +17,7 @@ subtest "do not index bare .pm but report rejection" => sub { my $result = $pause->test_reindex; - $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( [ @@ -42,6 +39,8 @@ subtest "perl-\\d should not get indexed" => sub { my $result = $pause->test_reindex; + $result->assert_index_updated; + $result->package_list_ok( [ { package => 'Soft::Ware', version => '2' }, @@ -66,6 +65,7 @@ subtest "should index single-life dev vers. modules in perl dist" => sub { $pause->upload_author_file('OPRIME', 'perl-5.20.2.tar.gz'); my $result = $pause->test_reindex; + $result->assert_index_updated; my $packages = $result->packages_data; ok($packages->package("POSIX"), "we index POSIX in a dev version"); @@ -156,6 +156,7 @@ subtest "do not index if meta has release_status <> stable" => sub { { my $result = $pause->test_reindex; + $result->assert_index_updated; $result->email_ok([ { subject => 'PAUSE indexer report OPRIME/Pie-Eater-1.23.tar.gz' }, @@ -175,6 +176,7 @@ subtest "do not index if meta has release_status <> stable" => sub { ); my $result = $pause->test_reindex; + $result->assert_index_updated; $result->package_list_ok([ { package => 'Pie::Eater', version => '1.23' }, @@ -213,6 +215,7 @@ subtest "warn when pkg and module match only case insensitively" => sub { }); my $result = $pause->test_reindex; + $result->assert_index_updated; $result->package_list_ok( [ @@ -259,6 +262,7 @@ subtest "(package NAME VERSION BLOCK) and (package NAME BLOCK)" => sub { }); my $result = $pause->test_reindex; + $result->assert_index_updated; $result->package_list_ok( [ @@ -291,12 +295,7 @@ subtest "check various forms of version" => 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; # VVVVVV - just fine! index it # VVVVVV::Bogus - utterly busted, give up @@ -339,6 +338,7 @@ EOT }); my $result = $pause->test_reindex; + $result->assert_index_updated; $result->package_list_ok([ { package => 'Globby::Version', version => '1.234' }, @@ -360,12 +360,7 @@ subtest "check overlong versions" => sub { }); my $result = $pause->test_reindex; - - $pause->file_not_updated_ok( - $result->tmpdir - ->file(qw(cpan modules 02packages.details.txt.gz)), - "there were no things to update", - ); + $result->assert_index_not_updated; my $etoolong = sub { like( @@ -406,6 +401,7 @@ subtest "case-changing imports" => sub { }); my $result = $pause->test_reindex; + $result->assert_index_updated; $result->package_list_ok([ { package => 'Foo::Bar', version => '0.001' }, @@ -426,6 +422,7 @@ subtest "case-changing imports" => sub { }); my $result = $pause->test_reindex; + $result->assert_index_updated; $result->package_list_ok([ { package => 'foo::bar', version => '0.002' }, @@ -445,6 +442,8 @@ subtest "check perl6 distribution indexing" => sub { $pause->import_author_root('corpus/mld/perl6/authors'); my $result = $pause->test_reindex; + $result->assert_index_not_updated("p5 index not updated on p6 upload"); + $result->p6dists_ok( [ { name => 'Inline', ver => '1.1' }, @@ -504,6 +503,7 @@ EOT }); my $result = $pause->test_reindex; + $result->assert_index_updated; $result->package_list_ok([ { package => 'Version::Cmp', version => '1.234' }, @@ -539,6 +539,7 @@ EOT }); my $result = $pause->test_reindex; + $result->assert_index_updated; $result->package_list_ok([ { package => 'Lingua::JA::Numbers', version => '0.05' }, @@ -556,12 +557,7 @@ subtest "do not index dists without META file" => sub { }); my $result = $pause->test_reindex; - - $pause->file_not_updated_ok( - $result->tmpdir - ->file(qw(cpan modules 02packages.details.txt.gz)), - "there were no things to update", - ); + $result->assert_index_not_updated; my $nometa = sub { like( From 4b6dcdb54d14e469c7b79ebeb112fa0ac01bf9fb Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 15:13:55 -0400 Subject: [PATCH 02/17] tests: remove the old file-updated check methods --- t/lib/PAUSE/TestPAUSE.pm | 67 ---------------------------------------- 1 file changed, 67 deletions(-) diff --git a/t/lib/PAUSE/TestPAUSE.pm b/t/lib/PAUSE/TestPAUSE.pm index 8419aa00c..6dc8d1654 100644 --- a/t/lib/PAUSE/TestPAUSE.pm +++ b/t/lib/PAUSE/TestPAUSE.pm @@ -390,73 +390,6 @@ sub test_reindex { }); } -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) = @_; From 565cb74108ecf91758ca4c7210d82685abac7693 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 10:03:46 -0400 Subject: [PATCH 03/17] indexer tests: split tests for indexing perl into a new file --- t/mldistwatch-misc.t | 45 ----------------------------------- t/mldistwatch-perl.t | 56 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 56 insertions(+), 45 deletions(-) create mode 100644 t/mldistwatch-perl.t diff --git a/t/mldistwatch-misc.t b/t/mldistwatch-misc.t index ff88408d0..c57f3c614 100644 --- a/t/mldistwatch-misc.t +++ b/t/mldistwatch-misc.t @@ -26,51 +26,6 @@ subtest "do not index bare .pm but report rejection" => sub { ); }; -subtest "perl-\\d should not get indexed" => sub { - my $pause = PAUSE::TestPAUSE->init_new; - - $pause->upload_author_fake(PLUGH => 'Soft-Ware-2'); - - $pause->upload_author_fake(PLUGH => { - name => 'perl', - version => 6, - packages => [ 'perl::rocks' ], - }); - - my $result = $pause->test_reindex; - - $result->assert_index_updated; - - $result->package_list_ok( - [ - { package => 'Soft::Ware', version => '2' }, - ], - ); - - # TODO: send a report saying 'no perl-X allowed' -}; - -subtest "should index single-life dev vers. modules in perl dist" => sub { - plan skip_all => "this test only run when perl-5.20.2.tar.gz found" - unless -e 'perl-5.20.2.tar.gz'; - - my $pause = PAUSE::TestPAUSE->init_new; - - my $initial_result = $pause->test_reindex; - - my $dbh = $initial_result->connect_authen_db; - die "couldn't make OPRIME a pumpking" - unless $dbh->do("INSERT INTO grouptable (user, ugroup) VALUES ('OPRIME', 'pumpking')"); - - $pause->upload_author_file('OPRIME', 'perl-5.20.2.tar.gz'); - - my $result = $pause->test_reindex; - $result->assert_index_updated; - - my $packages = $result->packages_data; - ok($packages->package("POSIX"), "we index POSIX in a dev version"); -}; - sub refused_index_test { my ($arg) = @_; diff --git a/t/mldistwatch-perl.t b/t/mldistwatch-perl.t new file mode 100644 index 000000000..bd2e39329 --- /dev/null +++ b/t/mldistwatch-perl.t @@ -0,0 +1,56 @@ +use strict; +use warnings; + +use 5.10.1; +use lib 't/lib'; +use lib 't/privatelib'; # Stub PrivatePAUSE + +use File::Spec; +use PAUSE; +use PAUSE::TestPAUSE; + +use Test::More; + +subtest "perl-\\d should not get indexed" => sub { + my $pause = PAUSE::TestPAUSE->init_new; + + $pause->upload_author_fake(PLUGH => 'Soft-Ware-2'); + + $pause->upload_author_fake(PLUGH => { + name => 'perl', + version => 6, + packages => [ 'perl::rocks' ], + }); + + my $result = $pause->test_reindex; + + $result->package_list_ok( + [ + { package => 'Soft::Ware', version => '2' }, + ], + ); + + # TODO: send a report saying 'no perl-X allowed' +}; + +subtest "should index single-life dev vers. modules in perl dist" => sub { + plan skip_all => "this test only run when perl-5.20.2.tar.gz found" + unless -e 'perl-5.20.2.tar.gz'; + + my $pause = PAUSE::TestPAUSE->init_new; + + my $initial_result = $pause->test_reindex; + + my $dbh = $initial_result->connect_authen_db; + die "couldn't make OPRIME a pumpking" + unless $dbh->do("INSERT INTO grouptable (user, ugroup) VALUES ('OPRIME', 'pumpking')"); + + $pause->upload_author_file('OPRIME', 'perl-5.20.2.tar.gz'); + + my $result = $pause->test_reindex; + + my $packages = $result->packages_data; + ok($packages->package("POSIX"), "we index POSIX in a dev version"); +}; + +done_testing; From aff528fa9933c5563627a357e2c5ed13e9532cf2 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 10:54:28 -0400 Subject: [PATCH 04/17] indexer tests: test that an authorized perl release is indexed --- t/mldistwatch-perl.t | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/t/mldistwatch-perl.t b/t/mldistwatch-perl.t index bd2e39329..defec5dee 100644 --- a/t/mldistwatch-perl.t +++ b/t/mldistwatch-perl.t @@ -53,4 +53,31 @@ subtest "should index single-life dev vers. modules in perl dist" => sub { ok($packages->package("POSIX"), "we index POSIX in a dev version"); }; +subtest "indexing a new perl" => sub { + my $pause = PAUSE::TestPAUSE->init_new; + + my $initial_result = $pause->test_reindex; + my $dbh = $initial_result->connect_authen_db; + + die "couldn't make OPRIME a pumpking" + unless $dbh->do("INSERT INTO grouptable (user, ugroup) VALUES ('OPRIME', 'pumpking')"); + + $pause->upload_author_fake(OPRIME => { + name => 'perl', + version => '5.56.55', + packages => [ 'Perl::Core' ], + packages => [ + 'Perl::Core' => { version => '1.002' }, + ], + }); + + my $result = $pause->test_reindex; + + $result->package_list_ok( + [ + { package => 'Perl::Core', version => '1.002' }, + ], + ); +}; + done_testing; From f2d66566914e2e723f59ed4bbca2ff986d2801c3 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 12:39:25 -0400 Subject: [PATCH 05/17] TestPAUSE: add upload_author_garbage to upload non-archive noise (I want to test files we can't extract.) --- t/lib/PAUSE/TestPAUSE.pm | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/t/lib/PAUSE/TestPAUSE.pm b/t/lib/PAUSE/TestPAUSE.pm index 6dc8d1654..89cc84f62 100644 --- a/t/lib/PAUSE/TestPAUSE.pm +++ b/t/lib/PAUSE/TestPAUSE.pm @@ -14,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." @@ -236,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', From ca4b0a46a8a51dfb50e827260a7237c609fc7f64 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 12:39:52 -0400 Subject: [PATCH 06/17] TestPAUSE: track per-index-run log events ...and add methods to check or print them. --- t/lib/PAUSE/TestPAUSE.pm | 10 +++++++++- t/lib/PAUSE/TestPAUSE/Result.pm | 22 ++++++++++++++++++++++ 2 files changed, 31 insertions(+), 1 deletion(-) diff --git a/t/lib/PAUSE/TestPAUSE.pm b/t/lib/PAUSE/TestPAUSE.pm index 89cc84f62..ce747c193 100644 --- a/t/lib/PAUSE/TestPAUSE.pm +++ b/t/lib/PAUSE/TestPAUSE.pm @@ -373,6 +373,8 @@ 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, $_) @@ -396,18 +398,24 @@ sub test_reindex { $arg->{after}->($self->tmpdir) if $arg->{after}; - my $new_package_state = filestate($package_file); + # The first $existing_log_events were already there. We only care about + # once 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, }); }); diff --git a/t/lib/PAUSE/TestPAUSE/Result.pm b/t/lib/PAUSE/TestPAUSE/Result.pm index 70cc24b5b..007ae0714 100644 --- a/t/lib/PAUSE/TestPAUSE/Result.pm +++ b/t/lib/PAUSE/TestPAUSE/Result.pm @@ -192,4 +192,26 @@ sub assert_index_not_updated ($self, $desc = "02packages was not changed") { 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; From 35f09ea333b710d99cc9d7b1ba7b52efb346fe88 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 12:40:06 -0400 Subject: [PATCH 07/17] indexer tests: test that we skip dev-version uploads (by filename) --- t/mldistwatch-misc.t | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/t/mldistwatch-misc.t b/t/mldistwatch-misc.t index c57f3c614..f82004b8b 100644 --- a/t/mldistwatch-misc.t +++ b/t/mldistwatch-misc.t @@ -532,6 +532,40 @@ subtest "do not index dists without META file" => sub { ); }; +subtest "do not index dists without trial versions" => sub { + for my $test ( + { desc => "low line in version", munger => sub { $_[0] =~ s/22/2_2/r } }, + { desc => "TRIAL in version", munger => sub { $_[0] =~ s/22/22-TRIAL/r } }, + ) { + subtest $test->{desc} => sub { + my $pause = PAUSE::TestPAUSE->init_new; + + # Module::Faker will give us a bit of grief for uploading a file called + # 1.2_2 because it wants to set META release status to stable, and the + # low line is in conflict with that. Rather than muck about making this + # permissible, I'm going to write out the archive, then rename it before + # indexing. + my $old_name = $pause->upload_author_fake(PERSON => 'Just-Testing-1.22.tar.gz'); + my $new_name = $test->{munger}->($old_name); + + rename($old_name, $new_name) or die "can't rename $old_name: $!"; + + my $result = $pause->test_reindex; + + $pause->file_not_updated_ok( + $result->tmpdir + ->file(qw(cpan modules 02packages.details.txt.gz)), + "there were no things to update", + ); + + $result->logged_event_like( + qr{\Qdist is a developer release}, + "we do not index trial-like filenames", + ); + }; + } +}; + done_testing; # Local Variables: From 97ac932b3346d51610b854a1f748fc1abcba3207 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 12:40:37 -0400 Subject: [PATCH 08/17] indexer tests: clarify which case our existing not-indexed test is (Specificaly: it is perl-like, not unauthorized real perl.) --- t/mldistwatch-perl.t | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/t/mldistwatch-perl.t b/t/mldistwatch-perl.t index defec5dee..ac33b82b4 100644 --- a/t/mldistwatch-perl.t +++ b/t/mldistwatch-perl.t @@ -11,7 +11,7 @@ use PAUSE::TestPAUSE; use Test::More; -subtest "perl-\\d should not get indexed" => sub { +subtest "perl-\\d should not get indexed (not really perl)" => sub { my $pause = PAUSE::TestPAUSE->init_new; $pause->upload_author_fake(PLUGH => 'Soft-Ware-2'); @@ -31,6 +31,11 @@ subtest "perl-\\d should not get indexed" => sub { ); # TODO: send a report saying 'no perl-X allowed' + + $result->logged_event_like( + qr{dist is an unofficial perl-like release}, + "perl-6.tar.gz is not a really perl-like file", + ); }; subtest "should index single-life dev vers. modules in perl dist" => sub { From 79903b6b710e1e5911ca338262080c0d4dad23d2 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 12:40:51 -0400 Subject: [PATCH 09/17] indexer tests: test more cases of uploading a perl release --- t/mldistwatch-perl.t | 54 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) diff --git a/t/mldistwatch-perl.t b/t/mldistwatch-perl.t index ac33b82b4..1edae75c5 100644 --- a/t/mldistwatch-perl.t +++ b/t/mldistwatch-perl.t @@ -58,6 +58,35 @@ subtest "should index single-life dev vers. modules in perl dist" => sub { ok($packages->package("POSIX"), "we index POSIX in a dev version"); }; +subtest "reject perl by unauthorized user" => sub { + my $pause = PAUSE::TestPAUSE->init_new; + + my $initial_result = $pause->test_reindex; + my $dbh = $initial_result->connect_authen_db; + + $pause->upload_author_fake(OPRIME => { + name => 'perl', + version => '5.56.55', + packages => [ 'Perl::Core' ], + packages => [ + 'Perl::Core' => { version => '1.002' }, + ], + }); + + my $result = $pause->test_reindex; + + $pause->file_not_updated_ok( + $result->tmpdir + ->file(qw(cpan modules 02packages.details.txt.gz)), + "there were no things to update", + ); + + $result->logged_event_like( + qr{\Qperl dist O/OP/OPRIME/perl-5.56.55.tar.gz from untrusted user OPRIME}, + "rejected because user it not trusted to upload perl", + ); +}; + subtest "indexing a new perl" => sub { my $pause = PAUSE::TestPAUSE->init_new; @@ -85,4 +114,29 @@ subtest "indexing a new perl" => sub { ); }; +subtest "indexing a new perl, but file is not a proper tar.gz" => sub { + my $pause = PAUSE::TestPAUSE->init_new; + + my $initial_result = $pause->test_reindex; + my $dbh = $initial_result->connect_authen_db; + + die "couldn't make OPRIME a pumpking" + unless $dbh->do("INSERT INTO grouptable (user, ugroup) VALUES ('OPRIME', 'pumpking')"); + + $pause->upload_author_garbage(OPRIME => "perl-5.56.55.tar.gz"); + + my $result = $pause->test_reindex; + + $pause->file_not_updated_ok( + $result->tmpdir + ->file(qw(cpan modules 02packages.details.txt.gz)), + "there were no things to update", + ); + + $result->logged_event_like( + qr{\Qcould not untar O/OP/OPRIME/perl-5.56.55.tar.gz}, + "you can't index what you can't extract", + ); +}; + done_testing; From 640cb08232168e9cca864265c2bbe620f88b6b6c Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 17:05:06 -0400 Subject: [PATCH 10/17] indexer tests: test for new version of indexed dist --- t/mldistwatch-misc.t | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/t/mldistwatch-misc.t b/t/mldistwatch-misc.t index f82004b8b..7dd65d878 100644 --- a/t/mldistwatch-misc.t +++ b/t/mldistwatch-misc.t @@ -566,6 +566,42 @@ subtest "do not index dists without trial versions" => sub { } }; +subtest "updates to existing packages " => sub { + my $pause = PAUSE::TestPAUSE->init_new; + + subtest "first version" => sub { + $pause->upload_author_fake(MTRON => 'Eye-Meeter-1.234.tar.gz'); + + my $result = $pause->test_reindex; + + $pause->file_updated_ok( + $result->tmpdir + ->file(qw(cpan modules 02packages.details.txt.gz)), + "index updated", + ); + + $result->package_list_ok([ + { package => 'Eye::Meeter', version => '1.234' }, + ]); + }; + + subtest "second version" => sub { + $pause->upload_author_fake(MTRON => 'Eye-Meeter-1.235.tar.gz'); + + my $result = $pause->test_reindex; + + $pause->file_updated_ok( + $result->tmpdir + ->file(qw(cpan modules 02packages.details.txt.gz)), + "index updated", + ); + + $result->package_list_ok([ + { package => 'Eye::Meeter', version => '1.235' }, + ]); + }; +}; + done_testing; # Local Variables: From 5cb7ab4c503830b1becb556d1845edc4aafd2537 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 18:45:55 -0400 Subject: [PATCH 11/17] indexer tests: test uploading a replacement perl dist --- t/mldistwatch-perl.t | 79 ++++++++++++++++++++++++++++++++++---------- 1 file changed, 62 insertions(+), 17 deletions(-) diff --git a/t/mldistwatch-perl.t b/t/mldistwatch-perl.t index 1edae75c5..3a8324352 100644 --- a/t/mldistwatch-perl.t +++ b/t/mldistwatch-perl.t @@ -87,7 +87,7 @@ subtest "reject perl by unauthorized user" => sub { ); }; -subtest "indexing a new perl" => sub { +subtest "indexing a new perl and then another one" => sub { my $pause = PAUSE::TestPAUSE->init_new; my $initial_result = $pause->test_reindex; @@ -96,22 +96,67 @@ subtest "indexing a new perl" => sub { die "couldn't make OPRIME a pumpking" unless $dbh->do("INSERT INTO grouptable (user, ugroup) VALUES ('OPRIME', 'pumpking')"); - $pause->upload_author_fake(OPRIME => { - name => 'perl', - version => '5.56.55', - packages => [ 'Perl::Core' ], - packages => [ - 'Perl::Core' => { version => '1.002' }, - ], - }); - - my $result = $pause->test_reindex; - - $result->package_list_ok( - [ - { package => 'Perl::Core', version => '1.002' }, - ], - ); + subtest "first version of perl" => sub { + $pause->upload_author_fake(OPRIME => { + name => 'perl', + version => '5.56.55', + packages => [ + 'Perl::Core' => { version => '1.002' }, + 'Little::Buddy' => { version => '2.003' }, + ], + }); + + my $result = $pause->test_reindex; + + $result->package_list_ok( + [ + { package => 'Little::Buddy', version => '2.003' }, + { package => 'Perl::Core', version => '1.002' }, + ], + ); + }; + + subtest "re-upload that same version again" => sub { + $pause->upload_author_fake(OPRIME => { + name => 'perl', + version => '5.56.55', + packages => [ + 'Perl::Core' => { version => '1.002' }, + 'Little::Buddy' => { version => '2.003' }, + ], + }); + + my $result = $pause->test_reindex; + + $result->package_list_ok( + [ + { package => 'Little::Buddy', version => '2.003' }, + { package => 'Perl::Core', version => '1.002' }, + ], + ); + }; + + subtest "actual next version of perl" => sub { + $pause->upload_author_fake(OPRIME => { + name => 'perl', + version => '5.56.56', + packages => [ + 'Little::Buddy' => { version => '2.345' }, + 'Newly::Added' => { version => '3.000' }, + 'Perl::Core' => { version => '1.002' }, + ], + }); + + my $result = $pause->test_reindex; + + $result->package_list_ok( + [ + { package => 'Little::Buddy', version => '2.345' }, + { package => 'Newly::Added', version => '3.000' }, + { package => 'Perl::Core', version => '1.002' }, + ], + ); + }; }; subtest "indexing a new perl, but file is not a proper tar.gz" => sub { From 350b4da5ecb97520ccb27ceef85d18307cd055d5 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 18:47:06 -0400 Subject: [PATCH 12/17] indexer tests: test dual-life release primacy That is: a new relase of perl-5, even if it contains a higher version of some dual-life package, should not replace the old package in the index, if it comes from a non-perl distribution. --- t/mldistwatch-perl.t | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/t/mldistwatch-perl.t b/t/mldistwatch-perl.t index 3a8324352..dff312b97 100644 --- a/t/mldistwatch-perl.t +++ b/t/mldistwatch-perl.t @@ -184,4 +184,48 @@ subtest "indexing a new perl, but file is not a proper tar.gz" => sub { ); }; +subtest "perl uploads do not unseat dual-life modules" => sub { + # When a perl dist upload includes a new version of something currently + # indexed in a non-perl dist, we do not replace it in the index. This test + # is for that rule. + my $pause = PAUSE::TestPAUSE->init_new; + + my $initial_result = $pause->test_reindex; + my $dbh = $initial_result->connect_authen_db; + + die "couldn't make OPRIME a pumpking" + unless $dbh->do("INSERT INTO grouptable (user, ugroup) VALUES ('OPRIME', 'pumpking')"); + + subtest "upload the standalone version of a dual-life dist" => sub { + $pause->upload_author_fake(OPRIME => "Little-Buddy-1.000.tar.gz"); + my $result = $pause->test_reindex; + + $result->package_list_ok( + [ + { package => 'Little::Buddy', version => '1.000' }, + ], + ); + }; + + subtest "upload the in-core version of a dual-life dist" => sub { + $pause->upload_author_fake(OPRIME => { + name => 'perl', + version => '5.56.55', + packages => [ + 'Perl::Core' => { version => '1.002' }, + 'Little::Buddy' => { version => '2.003' }, + ], + }); + + my $result = $pause->test_reindex; + + $result->package_list_ok( + [ + { package => 'Little::Buddy', version => '1.000' }, + { package => 'Perl::Core', version => '1.002' }, + ], + ); + }; +}; + done_testing; From 79b1a07d5c45a112aafa8f070aff8d099af2959d Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 18:58:51 -0400 Subject: [PATCH 13/17] indexer tests: test the handling of invalid version formats --- t/mldistwatch-misc.t | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/t/mldistwatch-misc.t b/t/mldistwatch-misc.t index 7dd65d878..3ddf9e680 100644 --- a/t/mldistwatch-misc.t +++ b/t/mldistwatch-misc.t @@ -339,6 +339,35 @@ subtest "check overlong versions" => sub { ); }; +subtest "version is not a lax version string" => sub { + my $pause = PAUSE::TestPAUSE->init_new; + $pause->upload_author_fake(MONSTER => 'Hex-Version-1.234.tar.gz', { + append => [ + { + file => "lib/Hex/Version/NoJoke.pm", + content => <<'EOT', +use strict; +use warnings; +package Hex::Version::NoJoke; +our $VERSION = '0x1p-1'; +1; +EOT + } + ], + }); + + my $result = $pause->test_reindex; + + $result->package_list_ok([ + { package => 'Hex::Version', version => '1.234' }, + ]); + + $result->logged_event_like( + qr/error with version/, + "0x1p-1 is a bad version", + ); +}; + subtest "case-changing imports" => sub { my $pause = PAUSE::TestPAUSE->init_new; From ac8bded08d83dda217ffeb67d0d16fe3b2f8be90 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 19:31:08 -0400 Subject: [PATCH 14/17] indexer tests: test that you can split a package out of core --- t/mldistwatch-perl.t | 49 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/t/mldistwatch-perl.t b/t/mldistwatch-perl.t index dff312b97..a0a4be420 100644 --- a/t/mldistwatch-perl.t +++ b/t/mldistwatch-perl.t @@ -228,4 +228,53 @@ subtest "perl uploads do not unseat dual-life modules" => sub { }; }; +subtest "non-perl can replace perl versions" => sub { + # The "separate then in-core" rule which says that the core won't shadow a + # separate upload only goes in one direction. If a library is first found in + # core, and then later uploaded outside, the newly uploaded package may + # become indexed in that new dist. + my $pause = PAUSE::TestPAUSE->init_new; + + my $initial_result = $pause->test_reindex; + my $dbh = $initial_result->connect_authen_db; + + die "couldn't make OPRIME a pumpking" + unless $dbh->do("INSERT INTO grouptable (user, ugroup) VALUES ('OPRIME', 'pumpking')"); + + my $perl_dist = 'O/OP/OPRIME/perl-5.56.55.tar.gz'; + my $other_dist = 'O/OP/OPRIME/Little-Buddy-3.000.tar.gz'; + + subtest "upload the in-core version of a dual-life dist" => sub { + $pause->upload_author_fake(OPRIME => { + name => 'perl', + version => '5.56.55', + packages => [ + 'Little::Buddy' => { version => '2.000' }, + 'Perl::Core' => { version => '1.002' }, + ], + }); + + my $result = $pause->test_reindex; + + $result->package_list_ok( + [ + { package => 'Little::Buddy', version => '2.000' }, + { package => 'Perl::Core', version => '1.002' }, + ], + ); + }; + + subtest "upload the standalone version of a dual-life dist" => sub { + $pause->upload_author_fake(OPRIME => "Little-Buddy-3.000.tar.gz"); + my $result = $pause->test_reindex; + + $result->package_list_ok( + [ + { package => 'Little::Buddy', version => '3.000' }, + { package => 'Perl::Core', version => '1.002' }, + ], + ); + }; +}; + done_testing; From 663a2389e2d6ce5929adfbdb48a9d02b1da8438a Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 20:00:13 -0400 Subject: [PATCH 15/17] indexer tests: test the handling of v0 (new mtime wins) --- t/mldistwatch-misc.t | 52 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 51 insertions(+), 1 deletion(-) diff --git a/t/mldistwatch-misc.t b/t/mldistwatch-misc.t index 3ddf9e680..379e317b8 100644 --- a/t/mldistwatch-misc.t +++ b/t/mldistwatch-misc.t @@ -1,13 +1,14 @@ use strict; use warnings; -use 5.10.1; +use v5.36.0; use lib 't/lib'; use lib 't/privatelib'; # Stub PrivatePAUSE use File::Spec; use PAUSE; use PAUSE::TestPAUSE; +use Process::Status; use Test::More; @@ -631,6 +632,55 @@ subtest "updates to existing packages " => sub { }; }; +subtest "the notorious version zero" => sub { + # When we've got two dists both of which provide version 0 (or version + # undef), we pick the winner by mtime. I hate this, but I will write a test + # so that I can someday more confidently forbid anything like this. Good + # grief. -- rjbs, 2024-05-11 + my $pause = PAUSE::TestPAUSE->init_new; + + my sub touch_file ($filename, $i) { + my $secs = sprintf '%02i', $i; + system("touch", '-m', '-d', "2020-01-02T03:04:${secs}Z", $filename); + Process::Status->assert_ok("touching $filename"); + } + + # First, a zero version package. + # Then, again, but file mtime is older. We keep the package on file. + # Then, again, but file mtime is newer. We switch to the new package. + my @tests = ( + { desc => "first upload", offset => 10, dist_v => '1.0', want => '1.0' }, + { desc => "second upload", offset => 5, dist_v => '1.1', want => '1.0' }, + { desc => "third upload", offset => 15, dist_v => '1.2', want => '1.2' }, + ); + + for my $test (@tests) { + subtest $test->{desc} => sub { + my $file = $pause->upload_author_fake(CIPHER => { + name => 'Zero', + version => $test->{dist_v}, + packages => [ + 'Zero' => { version => '0.000' }, + ], + }); + + touch_file($file, $test->{offset}); + + my $result = $pause->test_reindex; + + $result->package_list_ok([ + { package => 'Zero', version => '0.000' }, + ]); + + my $p = $result->packages_data; + + my $dist = $p->latest_distribution("Zero"); + is($dist->prefix, "C/CI/CIPHER/Zero-$test->{want}.tar.gz", "right dist indexed"); + is($dist->version, $test->{want}, "with the right version"); + }; + } +}; + done_testing; # Local Variables: From 280532c8b2a9f35458fe5aea5842ca83ced2497f Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 20:06:32 -0400 Subject: [PATCH 16/17] indexer tests: more converstion to assert_index_updated --- t/mldistwatch-misc.t | 18 +++--------------- t/mldistwatch-perl.t | 12 ++---------- 2 files changed, 5 insertions(+), 25 deletions(-) diff --git a/t/mldistwatch-misc.t b/t/mldistwatch-misc.t index 379e317b8..8b0ae6acb 100644 --- a/t/mldistwatch-misc.t +++ b/t/mldistwatch-misc.t @@ -582,11 +582,7 @@ subtest "do not index dists without trial versions" => sub { my $result = $pause->test_reindex; - $pause->file_not_updated_ok( - $result->tmpdir - ->file(qw(cpan modules 02packages.details.txt.gz)), - "there were no things to update", - ); + $result->assert_index_not_updated; $result->logged_event_like( qr{\Qdist is a developer release}, @@ -604,11 +600,7 @@ subtest "updates to existing packages " => sub { my $result = $pause->test_reindex; - $pause->file_updated_ok( - $result->tmpdir - ->file(qw(cpan modules 02packages.details.txt.gz)), - "index updated", - ); + $result->assert_index_updated; $result->package_list_ok([ { package => 'Eye::Meeter', version => '1.234' }, @@ -620,11 +612,7 @@ subtest "updates to existing packages " => sub { my $result = $pause->test_reindex; - $pause->file_updated_ok( - $result->tmpdir - ->file(qw(cpan modules 02packages.details.txt.gz)), - "index updated", - ); + $result->assert_index_updated; $result->package_list_ok([ { package => 'Eye::Meeter', version => '1.235' }, diff --git a/t/mldistwatch-perl.t b/t/mldistwatch-perl.t index a0a4be420..ef0a0f064 100644 --- a/t/mldistwatch-perl.t +++ b/t/mldistwatch-perl.t @@ -75,11 +75,7 @@ subtest "reject perl by unauthorized user" => sub { my $result = $pause->test_reindex; - $pause->file_not_updated_ok( - $result->tmpdir - ->file(qw(cpan modules 02packages.details.txt.gz)), - "there were no things to update", - ); + $result->assert_index_not_updated; $result->logged_event_like( qr{\Qperl dist O/OP/OPRIME/perl-5.56.55.tar.gz from untrusted user OPRIME}, @@ -172,11 +168,7 @@ subtest "indexing a new perl, but file is not a proper tar.gz" => sub { my $result = $pause->test_reindex; - $pause->file_not_updated_ok( - $result->tmpdir - ->file(qw(cpan modules 02packages.details.txt.gz)), - "there were no things to update", - ); + $result->assert_index_not_updated; $result->logged_event_like( qr{\Qcould not untar O/OP/OPRIME/perl-5.56.55.tar.gz}, From 84592b6e8ee7a75bd2e9ce013b243c9bc2045830 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sat, 11 May 2024 21:25:56 -0400 Subject: [PATCH 17/17] indexer tests: test ZIP archives This will not work until Module-Faker with chmod 0644-ing of files is released. --- t/mldistwatch-big.t | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/t/mldistwatch-big.t b/t/mldistwatch-big.t index 753b160fd..e85cb8db2 100644 --- a/t/mldistwatch-big.t +++ b/t/mldistwatch-big.t @@ -11,6 +11,29 @@ use PAUSE::TestPAUSE; use Test::More; +subtest "the simplest thing that could possibly work" => sub { + for my $ext (qw( tar.gz zip )) { + my $pause = PAUSE::TestPAUSE->init_new; + $pause->upload_author_fake(AIDEN => "Shoe-Keeper-1.23.$ext"); + + my $result = $pause->test_reindex; + + $result->diag_log_messages; + + $result->assert_index_updated; + + $result->package_list_ok( + [ { package => 'Shoe::Keeper', version => '1.23' } ], + ); + + $result->perm_list_ok({ 'Shoe::Keeper' => { f => 'AIDEN' } }); + + $result->email_ok( + [ { subject => "PAUSE indexer report AIDEN/Shoe-Keeper-1.23.$ext" } ], + ); + } +}; + subtest "first indexing" => sub { my $pause = PAUSE::TestPAUSE->init_new; $pause->import_author_root('corpus/mld/001/authors');