File Coverage

blib/lib/Data/CodeRepos/CommitPing.pm

Criterion	Covered	Total	%
statement	85	90	94.4
branch	24	30	80.0
condition	11	13	84.6
subroutine	14	18	77.7
pod	0	9	0.0
total	134	160	83.7

package Data::CodeRepos::CommitPing;

use strict;
use warnings;
our $VERSION = '0.03';

use Carp;
use DateTime;
use DateTime::Format::HTTP;
use YAML;

sub new {
    my($class, $stuff) = @_;
    croak 'usage: Data::CodeRepos::CommitPing->new($coderepos_commit_data)' unless $stuff;

    unless (ref $stuff eq 'HASH') {
        if (ref $stuff) {
            # if CGI object
            $stuff = eval { $stuff->param('yaml') };
            croak "bad object: $@" if $@;
        }
        $stuff = Load($stuff);
    }

    for my $key (qw/ author comment date files rev /) {
        croak 'invalid CodeRepos commit ping format' unless defined $stuff->{$key};
    }

    $stuff->{date} = DateTime::Format::HTTP->parse_datetime($stuff->{date});

    for (@{ $stuff->{files} }) {
        $_->{path_list} = [ split '/', $_->{path} ];
    }

    bless { %$stuff }, $class;
}

sub revision { shift->{rev} }
*rev = \&revision;
sub comment { shift->{comment} }
sub date { shift->{date} }
sub author { shift->{author} }
sub files { shift->{files} }

sub changes_base {
    my $self = shift;

    my $changes_projs = {};
    for my $file (@{ $self->{files} }) {
        next unless $file->{path_list}->[0];
        my $proj = 'proj_' . $file->{path_list}->[0];
        my $path = $self->$proj($file);
        $changes_projs->{$path}++;
    }

    for my $top ($self->toplevel_updates) {
        next unless $top->{status} eq '_U';
        my $path = join '/', @{ $top->{path_list} };
        delete $changes_projs->{$path};
    }

    my @ret;
    for my $path ( sort { $changes_projs->{$b} <=> $changes_projs->{$a} } keys %{ $changes_projs } ) {
        push @ret, $path;
    }
    return unless @ret;
    return @ret > 1 ? [ @ret ] : $ret[0];
}

sub toplevel_updates {
    my $self = shift;

    my @ret;
    for my $file (@{ $self->{files} }) {
        my @list = @{ $file->{path_list} };
        unless (($list[0] || '') eq 'lang' && ($list[2] || '') eq 'misc') {
            next if @list > 2;
        }
        push @ret, $file;
    }
    @ret;
}


# projects
# book  config  corp  dan  docs  dotfiles  lang  platform  poem  websites
our %PROJECT_BASE;
for my $proj (qw/ platform docs dan corp /) {
    $PROJECT_BASE{$proj} = 3;
}
for my $proj (qw/ config websites dotfiles poem book  /) {
    $PROJECT_BASE{$proj} = 2;
}

for my $proj (keys %PROJECT_BASE) {
    no strict 'refs';
    *{"proj_$proj"} = sub {
        use strict;
        my($self, $file) = @_;
        my @list = @{ $file->{path_list} };
        my $max = $PROJECT_BASE{$proj};
        $max = @list < $max ? scalar(@list) : $max;
        $max--;
        join '/', @list[0..$max];
    }
}

sub proj_lang {
    my($self, $file) = @_;
    my @list = @{ $file->{path_list} };
    my $max = scalar(@list) - 1;
    if ($list[2]) {
        if ($list[2] eq 'misc' || ($list[1] eq 'javascript' && $list[2] eq 'userscripts')) {
            $max = $list[3] ? 3 : 2;
        } else {
            $max = 2;
        }
    }
    join '/', @list[0..$max];
}


1;
__END__