From b9c905cd999bbd59f391b4ba3233d83cc8199486 Mon Sep 17 00:00:00 2001
From: Christian Walde <walde.christian@gmail.com>
Date: Thu, 21 Nov 2024 12:50:49 +0100
Subject: [PATCH] add downstream dependents to testing

---
 .gitignore             |  1 +
 xt/DepReqs.pm          | 72 +++++++++++++++++++++++++++++++++++++++---
 xt/dependent-modules.t |  6 ++--
 3 files changed, 72 insertions(+), 7 deletions(-)

diff --git a/.gitignore b/.gitignore
index 7dd668a8..20b5de4b 100644
--- a/.gitignore
+++ b/.gitignore
@@ -7,3 +7,4 @@
 /nytprof*
 /TODO
 /xt/cpanfile
+/xt/dependents
diff --git a/xt/DepReqs.pm b/xt/DepReqs.pm
index 1278c620..accc8188 100644
--- a/xt/DepReqs.pm
+++ b/xt/DepReqs.pm
@@ -9,6 +9,7 @@ use IO::All;
 use MetaCPAN::Client;
 use List::Util 'uniqstr';
 use Devel::Confess;
+use Safe::Isa '$_call_if_object';
 
 1;
 
@@ -48,6 +49,25 @@ sub exclusions {
         |Module-AnyEvent-Helper
         # https://github.com/Perceptyx/perl-opentracing-roles/issues/8
         |OpenTracing-AutoScope
+        # i'd rather spend the time on more broad users
+        |Dist-Zilla-PluginBundle-.*|Task-.*|Acme-.*
+        # requires modules that fail to install via cpm
+        |Bundle-BDFOY|CHI-Driver-MongoDB|Mail-SpamAssassin|MyCPAN-Indexer
+        |Net-API-Stripe-WebHook-Apache|Bencher-Scenario-Serializers|Bio-RNA-RNAaliSplit
+        |Kafka|Mail-Milter-Authentication|Provision-Unix
+    )$@x
+}
+
+sub cpm_install_fails {
+    qr@^(
+        Apache2::Const | AptPkg::Cache | AptPkg::Config | BSON::XS | Code::Splice
+        | Config::ApacheFile | Data::Dump::Steamer | Devel::MyDebugger
+        | Dist::Zilla::Plugin::Test::NewVersion | Git::Github::Creator | Hook::Lex::Wrap
+        | JSON::Parser::Regexp | JSON::Rabbit | MacOSX::Alias | Module::NotThere
+        | Mojo::Promise::Rile::HigherOrder | NicTool | Parse::DebianChangelog | PathTools
+        | PeGS::PDF | Perl::Critic::DEVELOPER | Pod::Simple::Subclassing | Proc::ProcessTable
+        | RNA | Razor2::Client::Agent | Some::Module | Tie::File::Timestamp | WordPress::Grep
+        | die | perlbench | ptkdb | require
     )$@x
 }
 
@@ -64,21 +84,37 @@ sub force_big_metacpan_fetch {
 sub run {
     my $old_fetch = force_big_metacpan_fetch;
 
-    my @deps =
-      Test::DependentModules::_get_deps PPI => { exclude => exclusions() };
-
     { no warnings 'redefine'; *MetaCPAN::Client::fetch = $old_fetch; }
 
     my $c = MetaCPAN::Client->new;
+
+    my @deps = _resolve_reverse_dependencies( PPI => 10, exclusions(), $c );
+
+    say "writing dependents file";
+    io( -e "xt" ? "xt/dependents" : "dependents" )->print( join "\n", @deps );
+
+    say "getting modules to pre-install";
+    my $cpm_fails = cpm_install_fails;
     my @reqs;
+    my @skip;
     for my $dependent (@deps) {
         say $dependent;
         my @dep_reqs = map @{ $c->release($_)->dependency }, $dependent;
-        say "   $_->{module}" for @dep_reqs;
+        my @fails =    #
+          map $_->{module}, grep $_->{module} =~ $cpm_fails, @dep_reqs;
+        if (@fails) {
+            push @skip, $dependent;
+            say "skipping dependent $dependent because "
+              . "it requires modules that fail to install: @fails";
+            next;
+        }
         push @reqs, @dep_reqs;
     }
+    say "skipping dependents because "
+      . "they requires modules that fail to install: @skip"
+      if @skip;
 
-    say "writing file";
+    say "writing dependency pre-install file";
     io("xt/cpanfile")
       ->print( join "\n",
         uniqstr map qq[requires "$_->{module}" => "$_->{version}";], @reqs );
@@ -88,8 +124,10 @@ sub run {
 
     # test early that all modules don't have an author that crashes tests later
     # !!! careful, this changes CWD !!!
+    say "testing dists for author names";
     Test::DependentModules::_load_cpan;
     for my $name (@deps) {
+        say $name;
         my $mod = $name;
         $mod =~ s/-/::/g;
         next unless    #
@@ -99,3 +137,27 @@ sub run {
 
     say "done";
 }
+
+sub _resolve_reverse_dependencies {
+    my ( $base_dist, $depth, $exclude, $c ) = @_;
+
+    my ( @work, %deps, %seen ) = ($base_dist);
+
+    for my $level ( 1 .. $depth ) {
+        say "resolving level: $level";
+        for my $dist (@work) {
+            my $deps = $c->rev_deps($dist);
+
+            while ( my $dist = $deps->next->$_call_if_object("distribution") ) {
+                next if $seen{$dist}++;
+                next if $exclude and $dist =~ $exclude;
+                $deps{$level}{$dist} = 1;
+            }
+        }
+
+        @work = sort keys %{ $deps{$level} };
+    }
+
+    my @deps = uniqstr map keys %{$_}, values %deps;
+    return sort @deps;
+}
diff --git a/xt/dependent-modules.t b/xt/dependent-modules.t
index bc28b8ce..d95742de 100644
--- a/xt/dependent-modules.t
+++ b/xt/dependent-modules.t
@@ -1,9 +1,10 @@
 use Test2::V0;
 use strictures 2;
 
-use Test::DependentModules 'test_all_dependents';
+use Test::DependentModules 'test_modules';
 use MetaCPAN::Client;
 use Devel::Confess;
+use IO::All;
 
 use lib '.';
 
@@ -19,7 +20,8 @@ my $new_log = sub { push @error_log, @_; $old_log->(@_); };
 
 DepReqs::force_big_metacpan_fetch();
 
-test_all_dependents PPI => { exclude => DepReqs::exclusions() };
+my @deps = split /\n/, io( -e "xt" ? "xt/dependents" : "dependents" )->all;
+test_modules @deps;
 
 my $error_log = join "\n", @error_log;
 my $fails     = join "\n", $error_log =~ /(FAIL: .*\w+)$/mg;