Add script for metacpan metadata updates

1 files changed, 230 insertions, 0 deletions

diff --git a/scripts/metadata-cpan-update.pl b/scripts/metadata-cpan-update.pl
new file mode 100755
index 000000000..a4a5654c8
--- /dev/null
+++ b/scripts/metadata-cpan-update.pl
@@ -0,0 +1,230 @@
+#!/usr/bin/env perl
+
+eval 'echo "Called with something not perl"' && exit 1    # Non-Perl protection.
+  if 0;
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use XML::Smart;
+use File::Slurp;
+use Data::Dumper;
+use CHI;
+use WWW::Mechanize::Cached;
+use HTTP::Tiny::Mech;
+use MetaCPAN::API;
+use Gentoo::Ebuild::ParseVariables qw(gentoo_ebuild_var);
+use CPAN::DistnameInfo;
+use Path::Class;
+use PortageXS;
+
+use metacpan qw( mcpan );
+my $mcpan = mcpan;
+#my $mcpan = MetaCPAN::API->new(
+#    ua => HTTP::Tiny::Mech->new(
+#        mechua => WWW::Mechanize::Cached->new(
+#            cache => CHI->new(
+#                driver   => 'File',
+#                root_dir => '/tmp/metacpan-cache',
+#            ),
+#        ),
+#    ),
+#);
+
+#my $portdir = '/var/gentoo/portage';
+my $portdir = PortageXS->new->getPortdir();
+my $dtd     = $portdir . "/metadata/dtd/metadata.dtd";
+
+while (@ARGV) {
+    my $md = shift @ARGV;
+    #print "$md\n";
+    my $dist;
+    my %cpan_modules;
+    my $metadata_old = read_file($md, binmode => ':utf8');
+    my $indent_level = indent($metadata_old);
+    my $metadata_new;
+    my $XML = XML::Smart->new($metadata_old);
+
+    #$XML->apply_dtd($dtd);
+    if ( check_remote_id($XML)
+        and not $XML->{pkgmetadata}->{upstream}
+        ->{'remote-id'}( 'type', 'eq', 'cpan' )->null() )
+    {
+        $dist =
+          $XML->{pkgmetadata}->{upstream}
+          ->{'remote-id'}( 'type', 'eq', 'cpan' )->content();
+    }
+    my $dist_src_uri = distname($md);
+    my $cpan_dist_failure;
+    if ( defined $dist and $dist ne '' and $dist ne $dist_src_uri ) {
+        print "Dist is wrong!\n";
+        print "'$dist' vs '$dist_src_uri'\n";
+        $cpan_dist_failure = 1;
+        $dist              = $dist_src_uri;
+    } elsif ( not defined $dist ) {
+	$dist = $dist_src_uri;
+    }
+
+    my $result = $mcpan->post(
+        'module/_search',
+        {
+            "fields" => [ "module.name", "release" ],
+            "query"  => {
+                "constant_score" => {
+                    "filter" => {
+                        "and" => [
+                            { "term" => { "distribution"      => "$dist" } },
+                            { "term" => { "status"            => "latest" } },
+                            { "term" => { "mime"              => "text/x-script.perl-module" } },
+                            { "term" => { "indexed"           => "true" } },
+                            { "term" => { "module.authorized" => "true" } }
+                        ]
+                    }
+                }
+            },
+            "size" => 990
+        }
+    );
+
+    return unless $result->{'hits'}->{'hits'};
+    for my $file ( @{ $result->{'hits'}->{'hits'} } ) {
+        if ( ref $file->{'fields'}->{'module.name'} eq 'ARRAY' ) {
+            for my $module ( @{ $file->{'fields'}->{'module.name'} } ) {
+                $cpan_modules{$module} += 2;
+            }
+        }
+        else {
+            $cpan_modules{ $file->{'fields'}->{'module.name'} } += 2;
+        }
+    }
+    drop_former_modules($XML, \%cpan_modules, $cpan_dist_failure);
+
+    if ( defined $dist and $dist ne '' ) {
+        if ( $XML->{pkgmetadata}->{upstream}
+            ->{'remote-id'}( 'type', 'eq', 'cpan' )->null() )
+        {
+            push @{ $XML->{pkgmetadata}->{upstream}->{"remote-id"} },
+              { type => 'cpan', content => "$dist" };
+        }
+        else {
+            if ( $XML->{pkgmetadata}->{upstream}
+                ->{'remote-id'}( 'type', 'eq', 'cpan' )->content() ne $dist )
+            {
+                push @{ $XML->{pkgmetadata}->{upstream}->{"remote-id"} },
+                  { type => 'cpan', content => "$dist" };
+            }
+        }
+    }
+
+    for my $module ( sort keys %cpan_modules ) {
+
+        print "Removed : $module\n" if $cpan_modules{$module} == 1;
+        print "Added   : $module\n" if $cpan_modules{$module} == 2;
+
+        push(
+            @{ $XML->{pkgmetadata}->{upstream}->{'remote-id'} },
+            { type => 'cpan-module', content => "$module" }
+        ) if $cpan_modules{$module} >= 2;
+    }
+    $metadata_new = '<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE pkgmetadata SYSTEM "http://www.gentoo.org/dtd/metadata.dtd">
+';
+    $metadata_new .= $XML->data( nometagen => 1, nodtd => 1, noheader => 1 );
+    $metadata_new =~ s/\n\Z//sm;
+
+    my $metadata_newnew;
+    for my $line ( split /\n/, $metadata_new ) {
+	if ( $line =~ m,^[ ]{4}(?=\<), ) {
+	    $line =~ s,^[ ]{4}(?=\<),$indent_level->{'second'},mseg;
+	} elsif ( $line =~ m,^[ ]{2}(?=\<), ) {
+	$line =~ s,^[ ]{2}(?=\<),$indent_level->{'first'},mseg;
+	}
+	$metadata_newnew .= $line . "\n";
+    }
+
+    write_file( "$md.new",{binmode => ':utf8'}, $metadata_newnew );
+    system("diff -ur $md $md.new");
+    rename "$md.new", "$md" or die "Can't rename $md.new: $!\n";
+
+}
+
+sub indent {
+    my $metadata = shift;
+    my %tags;
+    foreach my $tag (qw( herd maintainer longdescription use upstream )) {
+        $tags{"first"} = $1 if $metadata =~ m,.*?^([ \t]*)\<$tag,ms;
+    }
+    foreach my $tag (qw( remote-id name email )) {
+        $tags{"second"} = $1 if $metadata =~ m,.*?^([ \t]*)\<$tag,ms;
+    }
+    $tags{"second"} = "$tags{'first'}$tags{'first'}"
+      if not exists $tags{"second"};
+    return \%tags;
+}
+
+sub distname {
+    my $fd = shift;
+    $fd =~ s,metadata.xml,*.ebuild,;
+    my @ebuilds = glob "$fd";
+#    @ebuilds = reverse @ebuilds;
+    foreach my $ebuild ( reverse @ebuilds) {
+        $ebuild = file($ebuild)->absolute;
+        my $ebuild_hash = gentoo_ebuild_var(
+            "$ebuild",
+	    #[qw( MY_PN SRC_URI MY_PV MODULE_VERSION MODULE_A )],
+            [qw( SRC_URI )],
+	    #file($ebuild)->absolute->dir->parent->parent
+	    $portdir
+        );
+	next unless $ebuild_hash->{'SRC_URI'};
+        my @src_uri = split /\s/, $ebuild_hash->{'SRC_URI'};
+        foreach my $uri (@src_uri) {
+
+            next unless $uri =~ m,authors/id,;
+            return CPAN::DistnameInfo->new("$uri")->dist();
+        }
+	print Dumper $ebuild_hash;
+    }
+}
+
+sub check_remote_id {
+    my $xml = shift;
+    if ( $xml->{pkgmetadata}->null() ) {
+        print "metadata.xml: pkgmetadata does not exist\n";
+        return;
+    }
+    if ( $xml->{pkgmetadata}->{upstream}->null() ) {
+        print "metadata.xml: upstream does not exist\n";
+        return;
+    }
+    if ( $xml->{pkgmetadata}->{upstream}->{'remote-id'}->null() ) {
+        print "metadata.xml: remote-id does not exist\n";
+        return;
+    }
+    return 1;
+}
+
+sub drop_former_modules {
+    my $xml = shift;
+    my $cpan_modules = shift;
+    my $cpan_dist_failure = shift;
+    return unless check_remote_id($xml);
+    for my $remote ( @{ $xml->{pkgmetadata}->{upstream}->{'remote-id'} } ) {
+
+        #     print "Remote: $remote\n";
+        next unless exists $remote->{type};
+        if ( $remote->{type} eq 'cpan-module' ) {
+            $cpan_modules->{ $remote->content() } += 1;
+            undef $remote;
+        }
+        elsif ( $remote->{type} eq 'cpan' ) {
+            if ($cpan_dist_failure) {
+                print "undef cpan\n";
+
+                undef $remote;
+                undef $xml->{pkgmetadata}->{upstream};
+            }
+        }
+    }
+}