Only use author json files from CPAN, not BackPAN

Combine the code that reads the find-ls.gz file into a reusable method, and use it when checking author.json files, allowing authors to delete them.
metacpan · Feb 25, 2024 · 3e78bb3 · 3e78bb3
1 parent cfa30ff
commit 3e78bb3
Show file tree

Hide file tree

Showing 4 changed files with 33 additions and 48 deletions.
diff --git a/lib/MetaCPAN/Role/Script.pm b/lib/MetaCPAN/Role/Script.pm
@@ -28,6 +28,14 @@ has cpan => (
         'Location of a local CPAN mirror, looks for $ENV{MINICPAN} and ~/CPAN',
 );
 
+has cpan_file_map => (
+    is      => 'ro',
+    isa     => HashRef,
+    lazy    => 1,
+    builder => '_build_cpan_file_map',
+    traits  => ['NoGetopt'],
+);
+
 has die_on_error => (
     is            => 'ro',
     isa           => Bool,
@@ -225,6 +233,24 @@ sub _build_cpan {
 
 }
 
+sub _build_cpan_file_map {
+    my $self = shift;
+    my $ls   = $self->cpan->child(qw(indices find-ls.gz));
+    unless ( -e $ls ) {
+        die "File $ls does not exist";
+    }
+    log_info {"Reading $ls"};
+    my $cpan = {};
+    open my $fh, "<:gzip", $ls;
+    while (<$fh>) {
+        my $path = ( split(/\s+/) )[-1];
+        next unless ( $path =~ /^authors\/id\/\w+\/\w+\/(\w+)\/(.*)$/ );
+        $cpan->{$1}{$2} = 1;
+    }
+    close $fh;
+    return $cpan;
+}
+
 sub _build_quarantine {
     my $path = "$ENV{HOME}/QUARANTINE";
     if ( !-d $path ) {

diff --git a/lib/MetaCPAN/Script/Author.pm b/lib/MetaCPAN/Script/Author.pm
@@ -260,9 +260,13 @@ sub author_config {
     return undef
         unless $dir->is_dir;
 
+    my $author_cpan_files = $self->cpan_file_map->{$pauseid}
+        or return undef;
+
     # Get the most recent version
     my ($file) = map $_->[0], sort { $a->[1] <=> $b->[1] }
         map [ $_ => $_->stat->mtime ],
+        grep $author_cpan_files->{ $_->basename },
         $dir->children(qr/\Aauthor-.*\.json\z/);
 
     return undef

diff --git a/lib/MetaCPAN/Script/Backpan.pm b/lib/MetaCPAN/Script/Backpan.pm
@@ -31,13 +31,6 @@ has files_only => (
     documentation => 'only update the "file" index',
 );
 
-has _cpan_files_list => (
-    is      => 'ro',
-    isa     => HashRef,
-    lazy    => 1,
-    builder => '_build_cpan_files_list',
-);
-
 has _release_status => (
     is      => 'ro',
     isa     => HashRef,
@@ -50,25 +43,6 @@ has _bulk => (
     default => sub { +{} },
 );
 
-sub _build_cpan_files_list {
-    my $self = shift;
-    my $ls   = $self->cpan->child(qw(indices find-ls.gz));
-    unless ( -e $ls ) {
-        log_error {"File $ls does not exist"};
-        exit;
-    }
-    log_info {"Reading $ls"};
-    my $cpan = {};
-    open my $fh, "<:gzip", $ls;
-    while (<$fh>) {
-        my $path = ( split(/\s+/) )[-1];
-        next unless ( $path =~ /^authors\/id\/\w+\/\w+\/(\w+)\/(.*)$/ );
-        $cpan->{$1}{$2} = 1;
-    }
-    close $fh;
-    return $cpan;
-}
-
 sub run {
     my $self = shift;
 
@@ -106,7 +80,7 @@ sub build_release_status_map {
         $self->_release_status->{$author}{$name} = [
             (
                 $self->undo
-                    or exists $self->_cpan_files_list->{$author}{$archive}
+                    or exists $self->cpan_file_map->{$author}{$archive}
             )
             ? 'cpan'
             : 'backpan',

diff --git a/lib/MetaCPAN/Script/Release.pm b/lib/MetaCPAN/Script/Release.pm
@@ -187,7 +187,7 @@ sub run {
     my @module_to_purge_dists = map { CPAN::DistnameInfo->new($_) } @files;
 
     $self->index;
-    $self->_cpan_files_list if ( $self->detect_backpan );
+    $self->cpan_file_map if ( $self->detect_backpan );
     $self->perms;
     my @pid;
 
@@ -388,29 +388,10 @@ sub import_archive {
     $self->update_release_contirbutors($contrib_data);
 }
 
-sub _build_cpan_files_list {
-    my $self = shift;
-    my $ls   = $self->cpan->child(qw(indices find-ls.gz));
-    unless ( -e $ls ) {
-        log_error {"File $ls does not exist"};
-        exit;
-    }
-    log_info {"Reading $ls"};
-    my $cpan = {};
-    open my $fh, "<:gzip", $ls;
-    while (<$fh>) {
-        my $path = ( split(/\s+/) )[-1];
-        next unless ( $path =~ /^authors\/id\/\w+\/\w+\/(.*)$/ );
-        $cpan->{$1} = 1;
-    }
-    close $fh;
-    return $cpan;
-}
-
 sub detect_status {
     my ( $self, $author, $archive ) = @_;
     return $self->status unless ( $self->detect_backpan );
-    if ( $self->_cpan_files_list->{ join( '/', $author, $archive ) } ) {
+    if ( $self->cpan_file_map->{$author}{$archive} ) {
         return 'cpan';
     }
     else {