Updated external script

Author: mickeyn

bin/external.pl

@@ -8,8 +8,8 @@
 use MetaCPAN::Logger qw< :log :dlog >;
 
 use MetaCPAN::ES;
-use MetaCPAN::Ingest qw<
->;
+use MetaCPAN::External::Cygwin qw< run_cygwin >;
+use MetaCPAN::External::Debian qw< run_debian >;
 
 # with(
 #     'MetaCPAN::Script::Role::External::Cygwin',

lib/MetaCPAN/External/Cygwin.pm

@@ -0,0 +1,65 @@
+package MetaCPAN::External::Cygwin;
+
+use List::Util       qw< shuffle >;
+use MetaCPAN::Logger qw< :log :dlog >;
+
+use MetaCPAN::Ingest qw< ua >;
+
+use Sub::Exporter -setup => {
+    exports => [ qw<
+        run_cygwin
+    > ]
+};
+
+sub run_cygwin () {
+    my $ret = {};
+
+    my $ua = ua();
+    my $mirrors = get_mirrors($ua);
+
+    my @mirrors = @{ $mirrors };
+    my $timeout = $ua->timeout(10);
+
+  MIRROR: {
+        my $mirror = shift @mirrors or die "Ran out of mirrors";
+        log_debug {"Trying mirror: $mirror"};
+        my $res = $ua->get( $mirror . 'x86_64/setup.ini' );
+        redo MIRROR unless $res->is_success;
+
+        my @packages = split /^\@ /m, $res->decoded_content;
+        shift @packages;    # drop headers
+
+        log_debug { sprintf "Got %d cygwin packages", scalar @packages };
+
+        for my $desc (@packages) {
+            next if substr( $desc, 0, 5 ) ne 'perl-';
+            my ( $pkg, %attr ) = map s/\A"|"\z//gr, map s/ \z//r,
+                map s/\n+/ /gr, split /^([a-z]+): /m, $desc;
+            $attr{category} = [ split / /, $attr{category} ];
+            next if grep /^(Debug|_obsolete)$/, @{ $attr{category} };
+            $ret->{dist}{ $pkg =~ s/^perl-//r } = $pkg;
+        }
+    }
+    $ua->timeout($timeout);
+
+    log_debug {
+        sprintf "Found %d cygwin-CPAN packages",
+        scalar keys %{ $ret->{dist} }
+    };
+
+    return $ret;
+}
+
+sub _get_mirrors ( $ua ) {
+    log_debug {"Fetching mirror list"};
+    my $res = $ua->get('https://cygwin.com/mirrors.lst');
+    die "Failed to fetch mirror list: " . $res->status_line
+        unless $res->is_success;
+    my @mirrors = shuffle map +( split /;/ )[0], split /\n/,
+        $res->decoded_content;
+
+    log_debug { sprintf "Got %d mirrors", scalar @mirrors };
+    return \@mirrors;
+}
+
+1;

lib/MetaCPAN/External/Debian.pm

@@ -0,0 +1,112 @@
+package MetaCPAN::External::Debian;
+
+use strict;
+use warnings;
+use v5.36;
+
+use CPAN::DistnameInfo ();
+use DBI                ();
+
+use MetaCPAN::ES;
+
+use Sub::Exporter -setup => {
+    exports => [ qw<
+        run_debian
+    > ]
+};
+
+sub run_debian () {
+    my $ret = {};
+
+    my $host_regex = _get_host_regex();
+
+    # connect to the database
+    my $dbh = DBI->connect( "dbi:Pg:host=udd-mirror.debian.net;dbname=udd",
+        'udd-mirror', 'udd-mirror' );
+
+    # special cases
+    my %skip = ( 'libbssolv-perl' => 1 );
+
+    # multiple queries are needed
+    my @sql = (
+
+        # packages with upstream identified as CPAN
+        q{select u.source, u.upstream_url from upstream_metadata um join upstream u on um.source = u.source where um.key='Archive' and um.value='CPAN'},
+
+        # packages which upstream URL pointing to CPAN
+        qq{select source, upstream_url from upstream where upstream_url ~ '${\$host_regex}'},
+    );
+
+    my @failures;
+
+    for my $sql (@sql) {
+        my $sth = $dbh->prepare($sql);
+        $sth->execute();
+
+        # map Debian source package to CPAN distro
+        while ( my ( $source, $url ) = $sth->fetchrow ) {
+            next if $skip{$source};
+            if ( my $dist = dist_for_debian( $source, $url ) ) {
+                $ret->{dist}{$dist} = $source;
+            }
+            else {
+                push @failures => [ $source, $url ];
+            }
+        }
+    }
+
+    if (@failures) {
+        my $ret->{errors_email_body} = join "\n" =>
+            map { sprintf "%s %s", $_->[0], $_->[1] // '<undef>' } @failures;
+    }
+
+    return $ret;
+}
+
+sub dist_for_debian ( $source, $url ) {
+    my %alias = (
+        'datapager'   => 'data-pager',
+        'html-format' => 'html-formatter',
+    );
+
+    my $dist = CPAN::DistnameInfo->new($url);
+    if ( $dist->dist ) {
+        return $dist->dist;
+    }
+    elsif ( $source =~ /^lib(.*)-perl$/ ) {
+        my $es  = MetaCPAN::ES->new( type => 'release' );
+        my $res = $es->scroll(
+            body => {
+                query => {
+                    term => { 'distribution.lowercase' => $alias{$1} // $1 }
+                },
+                sort => [ { 'date' => 'desc' } ],
+            }
+        )->next;
+
+        return $res->{_source}{distribution}
+            if $res;
+    }
+
+    return;
+}
+
+sub _get_host_regex () {
+    my @cpan_hosts = qw<
+        backpan.cpan.org
+        backpan.perl.org
+        cpan.metacpan.org
+        cpan.noris.de
+        cpan.org
+        cpan.perl.org
+        search.cpan.org
+        www.cpan.org
+        www.perl.com
+    >;
+
+    return
+        '^(https?|ftp)://('
+        . join( '|', map {s/\./\\./r} @cpan_hosts ) . ')/';
+}
+
+1;