Commits

Toby Inkster committed 9c2a00a

Initial version

  • Participants

Comments (0)

Files changed (6)

+#!/usr/bin/env perl
+
+use P5U;
+use File::Basename 'basename';
+
+unshift $1, @ARGV
+	if basename($0) =~ /^p5u-(\w+)$/;
+
+P5U->run;
+
+__END__
+
+package P5U;
+
+use 5.010;
+use App::Cmd::Setup -app;
+
+BEGIN {
+	$P5U::AUTHORITY = 'cpan:TOBYINK';
+	$P5U::VERSION   = '0.001';
+}
+
+__PACKAGE__
+__END__
+
+=head1 NAME
+
+P5U - utilities for Perl 5 development and administration
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=P5U>.
+
+=head1 SEE ALSO
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2012 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+

File lib/P5U/Command/DebianRelease.pm

+package P5U::Command::DebianRelease;
+
+use 5.010;
+use strict;
+use P5U-command;
+
+use constant {
+	abstract    => q[show distribution version in Debian unstable],
+	description => q[],
+	usage_desc  => q[%c debian-release %o Distribution|CPANID],
+};
+
+sub command_names
+{
+	qw(
+		debian-release
+		debian
+	);
+}
+
+sub opt_spec
+{
+	return (
+		["author|a",       "query is an author"],
+		["distribution|d", "query is a distribution (default)"],
+	)
+}
+
+sub execute
+{
+	require P5U::Lib::DebianRelease;
+	
+	my ($self, $opt, $args) = @_;
+	
+	$self->usage_error("You must provide a distribution or author name.")
+		unless @$args;
+	$self->usage_error("Cannot request both author and distribution report.")
+		if $opt->{author} && $opt->{distribution};
+	
+	my $helper = P5U::Lib::DebianRelease::->new;
+	
+	if ($opt->{author})
+		{ print $helper->author_report($_) for @$args }
+	else
+		{ print $helper->distribution_report($_) for @$args }
+}
+
+1;

File lib/P5U/Command/Testers.pm

+package P5U::Command::Testers;
+
+use 5.010;
+use strict;
+use PerlX::Maybe 0 'maybe';
+use P5U-command;
+
+use constant {
+	abstract    => q[show CPAN testers statistics for a distribution],
+	description => q[],
+	usage_desc  => q[%c testers %o Distribution],
+};
+
+sub opt_spec
+{
+	return (
+		["version|v=s",  "a specific version to query"],
+		["summary|s",    "show summary for all versions"],
+		["os|o",         "break down statistics by operating system"],
+		["stable|z",     "ignore development versions"],
+	)
+}
+
+sub execute
+{
+	require P5U::Lib::Testers;
+	
+	my ($self, $opt, $args) = @_;
+
+	$self->usage_error("You must provide a distribution name.")
+		if $opt->{summary} && ($opt->{os_data} or length $opt->{version});
+		
+	$self->usage_error("You must provide a distribution name.")
+		if $opt->{stable} && length $opt->{version};
+	
+	my $distro = shift @$args
+		or $self->usage_error("You must provide a distribution name.");
+	$distro =~ s{::}{-}g;
+	
+	my $helper = P5U::Lib::Testers::->new(
+				distro  =>   $distro,
+				os_data => !!$opt->{os_data},
+				stable  => !!$opt->{stable},
+		maybe version =>   $opt->{version},
+	);
+	
+	if ($opt->{summary})
+		{ print $helper->summary_report }
+	else
+		{ print $helper->version_report }
+}
+
+1;

File lib/P5U/Lib/DebianRelease.pm

+package P5U::Lib::DebianRelease;
+
+# This is largely based on a script by SHARYANTO
+
+use 5.010;
+use utf8;
+use Any::Moose       0;
+use File::Slurp      0     qw< read_file >;
+use IO::Uncompress::Gunzip qw< gunzip $GunzipError >;
+use JSON             2.00  qw< from_json >;
+use LWP::Simple      0     qw< get >;
+use namespace::clean;
+
+my $cachef = "/tmp/allpackages.cache";
+my $json   = JSON->new->allow_nonref;
+
+sub dist2deb
+{
+	my ($dist) = @_;
+	"lib".lc($dist)."-perl";
+}
+
+has debian => (
+	is       => 'ro',
+	isa      => 'HashRef',
+	lazy     => 1,
+	builder  => '_build_debian',
+);
+
+sub _build_debian
+{
+	my %pkgs;
+	unless ((-f $cachef) && (-M _) < 7)
+	{
+		my $res = get "http://packages.debian.org/unstable/allpackages?format=txt.gz";
+		gunzip(\$res => $cachef) or die "gunzip failed: $GunzipError\n";
+	}
+	for (read_file $cachef)
+	{
+		next unless /^(lib\S+-perl) \((\S+?)\)/;
+		$pkgs{$1} = $2;
+	}
+	\%pkgs
+}
+
+sub author_report
+{
+	my $self = shift;
+	$self->format_report(
+		$self->author_data(@_)
+	)
+}
+
+sub distribution_report
+{
+	my $self = shift;
+	$self->format_report(
+		$self->distribution_data(@_)
+	)
+}
+
+sub format_report
+{
+	my ($self, $data) = @_;
+	join q(),
+		sprintf(
+			"%-40s%15s%15s  %s\n",
+			qw(PACKAGE CPAN DEBIAN WARNING)
+		),
+		map {
+			my ($dist, $cpan, $deb) = @$_;
+			(my $debx = $deb) =~ s/[-].+//;
+			sprintf(
+				"%-40s%15s%15s  %s\n",
+				  $dist,
+				  $cpan,
+				  $deb,
+				  ($debx eq $cpan ? q[  ] : q[!!]),
+			);
+		}
+		@$data;
+}
+
+sub author_data
+{
+	my ($self, $author) = @_;
+
+	my $res = get "http://api.metacpan.org/v0/release/_search?q=author:".
+		uc($author)."%20AND%20status:latest&fields=name&size=1000";
+	$res = $json->decode($res);
+	die "MetaCPAN timed out" if $res->{timed_out};
+
+	my $pkgs = $self->debian;
+
+	my %dists;
+	for my $hit (@{ $res->{hits}{hits} })
+	{
+		my $dist = $hit->{fields}{name};
+		$dist =~ s/-(\d.+)//;
+		$dists{$dist} = $1;
+	}
+
+	my @data;
+	for my $dist (sort keys %dists)
+	{
+		my $pkg = dist2deb($dist);
+		next unless $pkg ~~ $pkgs;
+		
+		push @data => [
+			$dist,
+			$dists{$dist},
+			$pkgs->{$pkg},
+		];
+	}
+	\@data;
+}
+
+sub distribution_data
+{
+	my $self = shift;
+	my $dist = from_json get sprintf('http://api.metacpan.org/v0/release/%s', @_);
+	my $pkg  = dist2deb $dist->{distribution};
+	
+	[[
+		$dist->{distribution},
+		$dist->{version},
+		($self->debian->{$pkg} // '(none)'),
+	]]
+}
+
+1;

File lib/P5U/Lib/Testers.pm

+package P5U::Lib::Testers;
+
+use 5.010;
+use strict;
+use utf8;
+use Any::Moose       0;
+use File::Path       0 qw< make_path >;
+use File::Spec       0 qw< >;
+use JSON             0 qw< from_json >;
+use LWP::Simple      0 qw< mirror is_success >;
+use List::Util       0 qw< maxstr >;
+use namespace::clean;
+
+has cache_dir => (
+	is       => 'ro',
+	isa      => 'Str',
+	lazy     => 1,
+	builder  => '_build_cache_dir',
+);
+
+has distro => (
+	is       => 'ro',
+	isa      => 'Str',
+	required => 1,
+);
+
+has results => (
+	is       => 'ro',
+	isa      => 'ArrayRef',
+	lazy     => 1,
+	builder  => '_build_results',
+);
+
+has version => (
+	is       => 'ro',
+	isa      => 'Str',
+	lazy     => 1,
+	builder  => '_build_version',
+);
+
+has os_data => (
+	is       => 'ro',
+	isa      => 'Bool',
+	default  => 0,
+);
+
+has stable => (
+	is       => 'ro',
+	isa      => 'Bool',
+	default  => 0,
+);
+
+sub version_data
+{
+	my ($self) = @_;
+	my %data;
+	foreach (@{$self->results})
+	{
+		next unless $_->{version} eq $self->version;
+		my ($pv) = ($_->{perl} =~ /^5\.(\d+)/) or next;
+		next if $pv ~~ [9, 11, 13, 15];
+		my $key = $self->os_data
+			? sprintf("Perl 5.%03d, %s", $pv, $_->{ostext})
+			: sprintf("Perl 5.%03d", $pv);
+		my $num  = { PASS => 0, FAIL => 1 }->{$_->{status}} // 2;
+		$data{$key}[$num]++;
+	}
+	return \%data;
+}
+
+sub summary_data
+{
+	my ($self) = @_;
+	my %data;
+	foreach (@{$self->results})
+	{
+		my $key  = $_->{version};
+		my $num  = { PASS => 0, FAIL => 1 }->{$_->{status}} // 2;
+		$data{$key}[$num]++;
+	}
+	return \%data;
+}
+
+sub format_report
+{
+	my ($self, $title, $data) = @_;
+	no warnings;
+	join "\n" => (
+		$title,
+		q(),
+		sprintf("%-32s%6s%6s%6s", q(), qw(PASS FAIL ETC)),
+		(
+			map { sprintf "%-32s% 6d% 6d% 6d", $_, @{$data->{$_}} }
+			sort keys %$data
+		),
+		q(),
+	);
+}
+
+sub version_report
+{
+	my ($self) = @_;
+	
+	$self->format_report(
+		sprintf("CPAN Testers results for %s version %s", $self->distro, $self->version),
+		$self->version_data,
+	);
+}
+
+sub summary_report
+{
+	my ($self, $os_data) = @_;
+	
+	$self->format_report(
+		sprintf("CPAN Testers results for %s", $self->distro),
+		$self->summary_data,
+	);
+}
+
+sub _build_version
+{
+	maxstr
+		map { $_->{version} }
+		@{ shift->results }
+}
+
+sub _build_results
+{
+	my $self = shift;
+	
+	my $results_uri = sprintf(
+		'http://www.cpantesters.org/distro/%s/%s.json',
+		substr($self->distro, 0, 1),
+		$self->distro,
+	);
+	my $results_file = File::Spec->catfile(
+		$self->cache_dir,
+		sprintf('%s.json', $self->distro),
+	);
+	
+	is_success mirror($results_uri => $results_file)
+		or do {
+			unlink $results_file;
+			die "Failed to retrieve URI $results_uri\n";
+		};
+		
+	my $results = from_json do {
+		open my $fh, '<', $results_file
+			or die "Could not open $results_file: $!";
+		local $/ = <$fh>;
+	};
+	die "Unexpected non-ARRAY content from $results_uri\n"
+		unless ref $results eq 'ARRAY';
+	
+	$self->stable
+		? [ grep { $_->{version} !~ /_/ } @$results ]
+		: $results;
+}
+
+sub _build_cache_dir
+{
+	my $dir = File::Spec->catdir(
+		File::Spec->tmpdir,
+		'CpanTesters',
+	);
+	make_path $dir unless -d $dir;
+	return $dir;
+}
+
+1;