use strict;
use warnings;
use 5.014;
use MetaCPAN::API;
use Text::Diff;
use XML::Feed;
use DateTime::Format::ISO8601;
use DateTime;
use HTML::Escape 'escape_html';
my $api = MetaCPAN::API->new();
package Release {
use Moose;
has [qw(distribution name author date abstract)] => (
is => 'ro',
);
around BUILDARGS => sub {
my ($orig,$class,$args) = @_;
if ($args->{fields}) {
$args = $args->{fields};
}
return $class->$orig($args);
};
sub get_file {
my ($self,$path) = @_;
my $file_response = $api->ua->get(
join '/',$api->base_url,'source',
$self->author,$self->name,$path
);
return unless $file_response->{success};
return $file_response->{content};
}
sub get_previous {
my ($self) = @_;
my $prev_release = $api->post(
'release/_search',
{
size => 1,
from => 0,
query => {
filtered => {
query => {
range => { date => {
to => $self->date,
include_upper => 0,
} },
},
filter => {
and => [ {
term => {
'release.distribution' => $self->distribution,
},
} ]
}
}
},
sort => [ { date => 'desc' } ],
fields => [qw(name author)],
},
);
($prev_release)=@{$prev_release->{hits}{hits}};
return unless $prev_release;
return ref($self)->new($prev_release);
}
sub search_files {
my ($self,@criteria) = @_;
my $files = $api->post(
'file/_search',
{
size => 30,
query => {
filtered => {
query => { match_all => {} },
filter => {
and => [
{ term => { release => $self->name } },
@criteria,
],
},
},
},
fields => [qw(name)],
}
);
return map { $_->{fields}{name} } @{$files->{hits}{hits}//[]};
}
sub get_changelog_name {
my ($self) = @_;
my @potential_changelogs = $self->search_files(
{ term => { level => 0 } },
{
or => [
{ prefix => { name => 'Change' } },
{ prefix => { name => 'change' } },
{ prefix => { name => 'CHANGE' } },
],
},
);
my ($changelog_name) = grep {
/^change(s|log)$/i
} @potential_changelogs;
return $changelog_name;
}
};
sub get_recent_releases {
my $now = DateTime->now;
my $yesterday = $now->clone->subtract(hours=>3);
my $recent = $api->post(
'release/_search',
{
size => 500,
from => 0,
query => {
range => { date => {
from => $yesterday->iso8601,
include_lower => 1,
} },
},
sort => [ { 'date' => { order => "desc" } } ],
fields => [qw(distribution name date author abstract)],
},
);
return map { Release->new($_) } @{$recent->{hits}{hits}//[]};
}
sub get_changelog_diff {
my ($release) = @_;
my $changelog_name = $release->get_changelog_name;
return {error=>'no changelog file'} unless $changelog_name;
my $this_changelog = $release->get_file($changelog_name);
my $prev_release = $release->get_previous;
return {diff=>$this_changelog} if !$prev_release;
my $prev_changelog = $prev_release->get_file($changelog_name);
return {diff=>$this_changelog} unless $prev_changelog;
my $diff = diff \$prev_changelog,\$this_changelog;
return {diff=>$diff} if $diff;
return {error=>'changelog not modified'};
}
sub build_feed {
my $feed = XML::Feed->new('Atom');
$feed->title('Recent CPAN uploads with Changelog diff');
$feed->link('http://metacpan.org');
return $feed;
}
sub build_entry {
my ($release) = @_;
my $e = XML::Feed::Entry->new('RSS');
$e->title( $release->name );
$e->link(
join( '/',
'http://metacpan.org', 'release',
$release->author, $release->name )
);
$e->author( $release->author );
$e->issued( DateTime::Format::ISO8601->parse_datetime( $release->date ) );
my $diff = get_changelog_diff($release);
my $content = sprintf '<p>%s</p>',
escape_html($release->abstract);
if ($diff->{diff}) {
$content .= sprintf '<pre>%s</pre>',
escape_html($diff->{diff});
}
else {
$content .= sprintf '<p>%s</p>',
escape_html($diff->{error});
}
$e->content($content);
return $e;
}
my $feed = build_feed();
my @recent = get_recent_releases();
for my $release (@recent) {
$feed->add_entry(build_entry($release));
}
print $feed->as_xml;
