Only use author json files from CPAN, not BackPAN

metacpan · Feb 25, 2024 · 51c1edc · 51c1edc
1 parent 5e04dad
commit 51c1edc
Show file tree

Hide file tree

Showing 6 changed files with 58 additions and 48 deletions.
diff --git a/cpanfile b/cpanfile
@@ -57,11 +57,13 @@ requires 'EV';
 requires 'Exporter', '5.74';
 requires 'ExtUtils::HasCompiler';
 requires 'File::Basename';
+requires 'File::Copy';
 requires 'File::Find';
 requires 'File::Find::Rule';
 requires 'File::Find::Rule::Perl';
 requires 'File::Spec';
 requires 'File::Spec::Functions';
+requires 'File::pushd';
 requires 'File::stat';
 requires 'File::Temp';
 requires 'FindBin';

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 {

diff --git a/t/lib/MetaCPAN/DarkPAN.pm b/t/lib/MetaCPAN/DarkPAN.pm
@@ -10,6 +10,8 @@ use OrePAN2::Indexer;
 use OrePAN2::Injector;
 use Path::Tiny    qw( path );
 use URI::FromHash qw( uri_object );
+use File::pushd   qw( pushd );
+use File::Copy    qw( copy );
 
 has base_dir => (
     is      => 'ro',
@@ -67,6 +69,7 @@ sub run {
     );
     $orepan->make_index( no_compress => 1, );
     $self->_write_06perms;
+    $self->_write_find_ls;
 }
 
 sub _write_06perms {
@@ -104,5 +107,25 @@ sub _write_06perms {
     $modules_dir->child('06perms.txt')->spew($content);
 }
 
+sub _write_find_ls {
+    my $self     = shift;
+    my $base_dir = $self->base_dir;
+
+    my $indices = $base_dir->child('indices');
+    $indices->mkpath;
+
+    my $find_ls = $indices->child('find-ls.gz')->openw(':gzip');
+
+    pushd($base_dir);
+
+    open my $fh, '-|', 'find', 'authors', '-ls'
+        or die "can't run find: $!";
+
+    copy $fh, $find_ls;
+
+    close $fh;
+    close $find_ls;
+}
+
 __PACKAGE__->meta->make_immutable;
 1;