From 954aa81d621321a52e5807505a7af595966442ed Mon Sep 17 00:00:00 2001
From: "H.Merijn Brand - Tux" <h.m.brand@xs4all.nl>
Date: Sat, 27 Sep 2014 13:27:29 +0200
Subject: [PATCH] used-by

---
 sandbox/used-by.pl | 172 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 172 insertions(+)
 create mode 100755 sandbox/used-by.pl

diff --git a/sandbox/used-by.pl b/sandbox/used-by.pl
new file mode 100755
index 0000000..45a1bf8
--- /dev/null
+++ b/sandbox/used-by.pl
@@ -0,0 +1,172 @@
+#!/pro/bin/perl
+
+use 5.16.2;
+use warnings;
+
+sub usage
+{
+    my $err = shift and select STDERR;
+    say "usage: $0 [--list]";
+    exit $err;
+    } # usage
+
+use Cwd;
+use LWP;
+use LWP::UserAgent;
+use HTML::TreeBuilder;
+use CPAN;
+use Capture::Tiny qw( :all );
+use Term::ANSIColor qw(:constants :constants256);
+use Test::More;
+
+use Getopt::Long qw(:config bundling passthrough);
+GetOptions (
+    "help|?"	=> sub { usage (0); },
+    "a|all!"	=> \my $opt_a,	# Also build for known FAIL (they might have fixed it)
+    "l|list!"	=> \my $opt_l,
+    ) or usage (1);
+
+my $tm = shift // do {
+    (my $d = getcwd) =~ s{.*CPAN/([^/]+)(?:/.*)?}{$1};
+    $d;
+    } or die "No module to check\n";
+
+diag ("Testing used-by for $tm\n");
+my %tm = map { $_ => 1 } qw( );
+
+$| = 1;
+$ENV{AUTOMATED_TESTING} = 1;
+# Skip all dists that
+# - are FAIL not due to the mudule being tested (e.g. POD or signature mismatch)
+# - that require interaction (not dealt with in distroprefs or %ENV)
+# - are not proper dists (cannot use CPAN's ->test)
+# - require external connections or special devices
+my %skip = $opt_a ? () : map { $_ => 1 } @{{
+    "Data-Peek"   => [
+	"GSM-Gnokii",				# External device
+	],
+    "DBD-CSV"     => [
+	"ASNMTAP",
+	],
+    "Text-CSV_XS" => [
+ 	"App-Framework",			# Questions
+	"CGI-Application-Framework",		# Unmet prerequisites
+	"CohortExplorer",			# Unmet prerequisites
+	"Connector",				# no Makefile.PL (in Annelidous)
+	"Finance-Bank-DE-NetBank",		# Module signatures
+	"RT-Extension-Assets-Import-CSV",	# Questions
+	"RT-View-ConciseSpreadsheet",		# Questions
+#	"Text-CSV-Track",			# encoding, patch filed at RT
+	"Text-ECSV",				# POD, spelling
+	"Text-MeCab",				# Questions
+	"Text-TEI-Collate",			# Unmet prerequisites
+	"Text-Tradition",			# Unmet prerequisites
+	"Tripletail",				# Makefile.PL broken
+	"WWW-Analytics-MultiTouch",		# Unmet prerequisites
+	"Webservice-InterMine",			# Unmet prerequisites
+	"YamlTime",				# Unmet prerequisites
+	"chart",				# Questions (in Apache::Wyrd)
+	"dbMan",				# Questions
+	"hwd",					# Own tests fail
+	"xDash",				# Questions
+#	"xls2csv",
+	],
+    }->{$tm} // []};
+
+my $ua  = LWP::UserAgent->new (agent => "Opera/12.15");
+
+sub get_from_cpantesters
+{
+    my $url = "http://deps.cpantesters.org/depended-on-by.pl?dist=$tm";
+    my $rsp = $ua->request (HTTP::Request->new (GET => $url));
+    unless ($rsp->is_success) {
+	warn "deps failed: ", $rsp->status_line, "\n";
+	return;
+	}
+    my $tree = HTML::TreeBuilder->new;
+       $tree->parse_content ($rsp->content);
+    my @h;
+    foreach my $a ($tree->look_down (_tag => "a", href => qr{query=})) {
+	(my $h = $a->attr ("href")) =~ s{.*=}{};
+	push @h, $h;
+	}
+    return @h;
+    } # get_from_cpantesters
+
+sub get_from_cpants
+{
+    my $url = "http://cpants.cpanauthors.org/dist/$tm/used_by";
+    my $rsp = $ua->request (HTTP::Request->new (GET => $url));
+    unless ($rsp->is_success) {
+	warn "cpants failed: ", $rsp->status_line, "\n";
+	return;
+	}
+    my $tree = HTML::TreeBuilder->new;
+       $tree->parse_content ($rsp->content);
+    my @h;
+    foreach my $a ($tree->look_down (_tag => "a", href => qr{/dist/})) {
+	(my $h = $a->attr ("href")) =~ s{.*dist/}{};
+	$h =~ m{^$tm\b} and next;
+	push @h, $h;
+	}
+    @h or diag ("$url might be rebuilding");
+    return @h;
+    } # get_from_cpants
+
+sub get_from_meta
+{
+    my $url = "https://metacpan.org/requires/distribution/$tm";
+    my $rsp = $ua->request (HTTP::Request->new (GET => $url));
+    unless ($rsp->is_success) {
+	warn "meta failed: ", $rsp->status_line, "\n";
+	return;
+	}
+    my $tree = HTML::TreeBuilder->new;
+       $tree->parse_content ($rsp->content);
+    my @h;
+    foreach my $a ($tree->look_down (_tag => "a", class => "ellipsis",
+					href => qr{/release/})) {
+	(my $h = $a->attr ("href")) =~ s{.*release/}{};
+	$h =~ m{^$tm\b} and next;
+	push @h, $h;
+	}
+    return @h;
+    } # get_from_meta
+
+foreach my $h ( get_from_cpants (),
+		get_from_cpantesters (),
+		get_from_meta (),
+		) {
+    exists $skip{$h} || $h =~ m{^( $tm (?: $ | / )
+				 | Task-
+				 | Bundle-
+				 | Win32-
+				 )\b}x and next;
+    (my $m = $h) =~ s/-/::/g;
+    $tm{$m} = 1;
+    }
+
+unless (keys %tm) {
+    ok (1, "No dependents found");
+    done_testing;
+    exit 0;
+    }
+
+if ($opt_l) {
+    ok (1, $_) for sort keys %tm;
+    done_testing;
+    exit 0;
+    }
+
+my %rslt;
+#$ENV{AUTOMATED_TESTING} = 1;
+foreach my $m (sort keys %tm) {
+    my $mod = CPAN::Shell->expand ("Module", "/$m/") or next;
+    # diag $m;
+    $rslt{$m}    = [ [], capture { $mod->test } ];
+    $rslt{$m}[0] = [ $?, $!, $@ ];
+    # say $? ? RED."FAIL".RESET : GREEN."PASS".RESET;
+    is ($?, 0, $m);
+    }
+
+done_testing;
-- 
2.11.4.GIT