Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 1f3e39d61a
Fetching contributors…

Cannot retrieve contributors at this time

299 lines (226 sloc) 8.311 kb
package modules::local::gitoriousparser;
use strict;
use warnings;
use XML::Atom::Client;
use HTML::Entities;
use base 'modules::local::karmalog';
=head1 NAME
This module is responsible for parsing ATOM feeds generated by
# When new feeds are configured, this number is incremented and added to the
# base timer interval in an attempt to stagger their occurance in time.
our $feed_number = 1;
# This is a map of $self objects. Because botnix does not use full class
# instances and instead calls package::name->function() to call methods, the
# actual OO storage for those modules ends up in here.
our %objects_by_package;
=head1 METHODS
=head2 fetch_feed
This is a pseudomethod called as a timer callback. It fetches the feed, parses
it into an XML::Atom::Feed object and passes that to process_feed().
This is the main entry point to this module. Botnix does not use full class
instances, instead it just calls by package name. This function maps from the
function name to a real $self object (stored in %objects_by_package).
sub fetch_feed {
my $pkg = shift;
my $self = $objects_by_package{$pkg};
my $atom = XML::Atom::Client->new();
my $feed = $atom->getFeed($$self{url});
=head2 process_feed
Enumerates the commits in the feed, emitting any events it hasn't seen before.
This subroutine manages a "seen" cache in $self, and will take care not to
announce any commit more than once.
The first time through, nothing is emitted. This is because we assume the bot
was just restarted ungracefully and the users have already seen all the old
events. So it just populates the seen-cache silently.
sub process_feed {
my ($pkg, $feed) = @_;
my $self = $objects_by_package{$pkg};
my @items = $feed->entries;
@items = sort { $a->updated cmp $b->updated } @items; # ascending order
my $newest = $items[-1];
my $latest = $newest->updated;
# skip the first run, to prevent new installs from flooding the channel
foreach my $item (@items) {
my @revs = $item->content->body =~ m|/commit/([a-z0-9]{40})|g;
for my $rev (reverse @revs) {
$self->output_item($item, $rev)
if !$$self{seen}{$rev}++ && $$self{not_first_time};
$$self{not_first_time} = 1;
=head2 longest_common_prefix
my $prefix = longest_common_prefix(@files);
Given a list of filenames, like ("src/ops/perl6.ops", "src/classes/IO.pir"),
returns the common prefix portion. For the example I just gave, the common
prefix would be "src/".
sub longest_common_prefix {
my $prefix = shift;
for (@_) {
chop $prefix while (! /^\Q$prefix\E/);
return $prefix;
=head2 try_link
['network', '#channel']
This is called by Given a URL, try to determine
the project name and canonical path. Then configure a feed reader for it if
one doesn't already exist.
The array reference containing network and channel are optional. If not
specified, magnet/#parrot is assumed. If the feed already exists but didn't
have the specified target, the existing feed is extended.
Currently supports the following URL format:
...with or without the "/" suffix.
sub try_link {
my ($pkg, $url, $target) = @_;
$target = ['magnet', '#parrot'] unless defined $target;
my $project;
if($url =~ m|[^/]+)/?|) {
$project = $1;
} else {
# whatever it is, we can't handle it. Log and return.
main::lprint("gitorious try_link(): I can't handle $url");
my $parsername = $project . "log";
my $modulename = "modules::local::" . $parsername;
$modulename =~ s/-/_/g;
if(exists($objects_by_package{$modulename})) {
# extend existing feed if necessary
my $self = $objects_by_package{$modulename};
my $already_have_target = 0;
foreach my $this (@{$$self{targets}}) {
if($$target[0] eq $$this[0] && $$target[1] eq $$this[1]);
push(@{$$self{targets}}, $target) unless $already_have_target;
# create new feed
# url, feed_name, targets, objects_by_package
my $rss_link = "$project.atom";
my $self = {
url => $rss_link,
feed_name => $project,
modulename => $modulename,
targets => [ $target ],
# create a dynamic subclass to get the timer callback back to us
eval "package $modulename; use base 'modules::local::gitoriousparser';";
$objects_by_package{$modulename} = bless($self, $modulename);
main::lprint("$parsername gitorious ATOM parser autoloaded.");
main::create_timer($parsername."_fetch_feed_timer", $modulename,
"fetch_feed", 300 + $feed_number++);
=head2 output_item
$self->output_item($item, $revision);
Takes an XML::Atom::Entry object, extracts the useful bits from it and calls
put() to emit the karma message.
The karma message is typically as follows:
feedname: $revision | username++ | :
feedname: One or more lines of commit log message
feedname: review: http://link/to/diff
sub output_item {
my ($self, $item, $rev) = @_;
my $link;
my $creator = $item->author;
if(defined($creator)) {
$creator = $creator->name;
} else {
$creator = 'unknown';
my $desc = $item->content;
if(defined($desc)) {
$desc = $desc->body;
} else {
$desc = '(no commit message)';
$desc = decode_entities($desc);
$desc =~ s,(<ul>),$1\n,g;
$desc =~ s,(</li>),$1\n,g;
my @lines = split "\n", $desc;
for my $line (@lines) {
my ($item) = $line =~ m,\s*<li>(.*)</li>$,;
next unless $item;
my ($name, $link)
= $item =~ m,^([^<]+)<a href="([^"]+)">[[:xdigit:]]{7}</a>:\s*[^<]+$,;
next unless $link;
my ($commit) = $link =~ m,/commit/([[:xdigit:]]{40}),;
next unless $commit && $commit eq $rev;
$link = "$link"
unless $link =~ m,^https?://,;
my $patch = $self->fetch_url("$link.patch");
my (@tmp, @log, @files, $this);
@tmp = split(/\n+/, $patch);
while(defined($this = shift(@tmp))) {
last if $this =~ /^Subject:/;
if(defined($this) && $this =~ /^Subject:\s*(?:\[PATCH\] ?)?(.+)/) {
push(@log, $1);
$this = shift(@tmp);
while(defined($this) && $this ne '---') {
$this =~ s/^\s+//;
push(@log, $this) if length $this;
$this = shift(@tmp);
$this = shift(@tmp);
while(defined($this)) {
if($this =~ /^\s+(\S+)\s+\|\s+\d+/) {
push(@files, $1);
} else {
$this = shift(@tmp);
my $prefix = longest_common_prefix(@files);
$prefix //= '/';
$prefix =~ s|^/||; # cut off the leading slash
if(scalar @files > 1) {
$prefix .= " (" . scalar(@files) . " files)";
$commit = substr($commit, 0, 7);
feed => $$self{feed_name},
rev => $commit,
user => $creator,
log => \@log,
link => $link,
prefix => $prefix,
targets => $$self{targets},
main::lprint($$self{feed_name}.": output_item: output rev $commit");
=head2 implements
This is a pseudo-method called by botnix to determine which event callbacks
this module supports. It is only called when explicitly subclassed (rakudo
does this). Returns an empty array.
sub implements {
return qw();
=head2 get_self
This is a helper method used by the test suite to fetch a feed's local state.
It isn't used in production.
sub get_self {
my $pkg = shift;
return $objects_by_package{$pkg};
Jump to Line
Something went wrong with that request. Please try again.