sandbox/used-by.pl

   1 #!/pro/bin/perl
   2
   3 use 5.16.2;
   4 use warnings;
   5
   6 sub usage
   7 {
   8     my $err = shift and select STDERR;
   9     say "usage: $0 [--list]";
  10     exit $err;
  11     } # usage
  12
  13 use Cwd;
  14 use LWP;
  15 use LWP::UserAgent;
  16 use HTML::TreeBuilder;
  17 use CPAN;
  18 use Capture::Tiny qw( :all );
  19 use Term::ANSIColor qw(:constants :constants256);
  20 use Test::More;
  21
  22 use Getopt::Long qw(:config bundling passthrough);
  23 GetOptions (
  24     "help|?"    => sub { usage (0); },
  25     "a|all!"    => \my $opt_a,  # Also build for known FAIL (they might have fixed it)
  26     "l|list!"   => \my $opt_l,
  27     ) or usage (1);
  28
  29 my $tm = shift // do {
  30     (my $d = getcwd) =~ s{.*CPAN/([^/]+)(?:/.*)?}{$1};
  31     $d;
  32     } or die "No module to check\n";
  33
  34 diag ("Testing used-by for $tm\n");
  35 my %tm = map { $_ => 1 } qw( );
  36
  37 $| = 1;
  38 $ENV{AUTOMATED_TESTING} = 1;
  39 # Skip all dists that
  40 # - are FAIL not due to the mudule being tested (e.g. POD or signature mismatch)
  41 # - that require interaction (not dealt with in distroprefs or %ENV)
  42 # - are not proper dists (cannot use CPAN's ->test)
  43 # - require external connections or special devices
  44 my %skip = $opt_a ? () : map { $_ => 1 } @{{
  45     "Data-Peek"   => [
  46         "GSM-Gnokii",                           # External device
  47         ],
  48     "DBD-CSV"     => [
  49         "ASNMTAP",
  50         ],
  51     "Text-CSV_XS" => [
  52         "App-Framework",                        # Questions
  53         "CGI-Application-Framework",            # Unmet prerequisites
  54         "CohortExplorer",                       # Unmet prerequisites
  55         "Connector",                            # no Makefile.PL (in Annelidous)
  56         "Finance-Bank-DE-NetBank",              # Module signatures
  57         "RT-Extension-Assets-Import-CSV",       # Questions
  58         "RT-View-ConciseSpreadsheet",           # Questions
  59 #       "Text-CSV-Track",                       # encoding, patch filed at RT
  60         "Text-ECSV",                            # POD, spelling
  61         "Text-MeCab",                           # Questions
  62         "Text-TEI-Collate",                     # Unmet prerequisites
  63         "Text-Tradition",                       # Unmet prerequisites
  64         "Tripletail",                           # Makefile.PL broken
  65         "WWW-Analytics-MultiTouch",             # Unmet prerequisites
  66         "Webservice-InterMine",                 # Unmet prerequisites
  67         "YamlTime",                             # Unmet prerequisites
  68         "chart",                                # Questions (in Apache::Wyrd)
  69         "dbMan",                                # Questions
  70         "hwd",                                  # Own tests fail
  71         "xDash",                                # Questions
  72 #       "xls2csv",
  73         ],
  74     }->{$tm} // []};
  75 my %add = (
  76     "Text-CSV_XS"  => [                         # Using Text::CSV, thus
  77         "Text-CSV-Auto",                        # optionally _XS
  78         "Text-CSV-R",
  79         "Text-CSV-Slurp",
  80         ],
  81     );
  82
  83 my $ua  = LWP::UserAgent->new (agent => "Opera/12.15");
  84
  85 sub get_from_cpantesters
  86 {
  87     my $url = "http://deps.cpantesters.org/depended-on-by.pl?dist=$tm";
  88     my $rsp = $ua->request (HTTP::Request->new (GET => $url));
  89     unless ($rsp->is_success) {
  90         warn "deps failed: ", $rsp->status_line, "\n";
  91         return;
  92         }
  93     my $tree = HTML::TreeBuilder->new;
  94        $tree->parse_content ($rsp->content);
  95     my @h;
  96     foreach my $a ($tree->look_down (_tag => "a", href => qr{query=})) {
  97         (my $h = $a->attr ("href")) =~ s{.*=}{};
  98         push @h, $h;
  99         }
 100     return @h;
 101     } # get_from_cpantesters
 102
 103 sub get_from_cpants
 104 {
 105     my $url = "http://cpants.cpanauthors.org/dist/$tm/used_by";
 106     my $rsp = $ua->request (HTTP::Request->new (GET => $url));
 107     unless ($rsp->is_success) {
 108         warn "cpants failed: ", $rsp->status_line, "\n";
 109         return;
 110         }
 111     my $tree = HTML::TreeBuilder->new;
 112        $tree->parse_content ($rsp->content);
 113     my @h;
 114     foreach my $a ($tree->look_down (_tag => "a", href => qr{/dist/})) {
 115         (my $h = $a->attr ("href")) =~ s{.*dist/}{};
 116         $h =~ m{^$tm\b} and next;
 117         push @h, $h;
 118         }
 119     @h or diag ("$url might be rebuilding");
 120     return @h;
 121     } # get_from_cpants
 122
 123 sub get_from_meta
 124 {
 125     my $url = "https://metacpan.org/requires/distribution/$tm";
 126     my $rsp = $ua->request (HTTP::Request->new (GET => $url));
 127     unless ($rsp->is_success) {
 128         warn "meta failed: ", $rsp->status_line, "\n";
 129         return;
 130         }
 131     my $tree = HTML::TreeBuilder->new;
 132        $tree->parse_content ($rsp->content);
 133     my @h;
 134     foreach my $a ($tree->look_down (_tag => "a", class => "ellipsis",
 135                                         href => qr{/release/})) {
 136         (my $h = $a->attr ("href")) =~ s{.*release/}{};
 137         $h =~ m{^$tm\b} and next;
 138         push @h, $h;
 139         }
 140     return @h;
 141     } # get_from_meta
 142
 143 foreach my $h ( get_from_cpants (),
 144                 get_from_cpantesters (),
 145                 get_from_meta (),
 146                 @{$add{$tm} || []},
 147                 ) {
 148     exists $skip{$h} || $h =~ m{^( $tm (?: $ | / )
 149                                  | Task-
 150                                  | Bundle-
 151                                  | Win32-
 152                                  )\b}x and next;
 153     (my $m = $h) =~ s/-/::/g;
 154     $tm{$m} = 1;
 155     }
 156
 157 unless (keys %tm) {
 158     ok (1, "No dependents found");
 159     done_testing;
 160     exit 0;
 161     }
 162
 163 if ($opt_l) {
 164     ok (1, $_) for sort keys %tm;
 165     done_testing;
 166     exit 0;
 167     }
 168
 169 my %rslt;
 170 #$ENV{AUTOMATED_TESTING} = 1;
 171 foreach my $m (sort keys %tm) {
 172     my $mod = CPAN::Shell->expand ("Module", "/$m/") or next;
 173     # diag $m;
 174     $rslt{$m}    = [ [], capture { $mod->test } ];
 175     $rslt{$m}[0] = [ $?, $!, $@ ];
 176     # say $? ? RED."FAIL".RESET : GREEN."PASS".RESET;
 177     is ($?, 0, $m);
 178     }
 179
 180 done_testing;