File Coverage

blib/lib/Mediawiki/Blame.pm

Criterion	Covered	Total	%
statement	46	48	95.8
branch			n/a
condition			n/a
subroutine	16	16	100.0
pod			n/a
total	62	64	96.8

package Mediawiki::Blame;
use 5.008;
use utf8;
use strict;
use warnings;
use Algorithm::Annotate qw();
use Carp qw(croak);
use Class::Spiffy qw(-base field const);
use DateTime qw();
use DateTime::Format::ISO8601 qw();
use LWP::UserAgent qw();
use Mediawiki::Blame::Revision qw();
use Mediawiki::Blame::Line qw();
use Params::Validate qw(validate_with SCALAR);
use Regexp::Common qw(number URI);
use Readonly qw(Readonly);
use XML::Twig qw();
our $VERSION = '0.0.3';

field 'export';
field 'page';
field 'ua_timeout';
field '_revisions';     # hashref whose keys are r_ids and values are hashrefs
field '_initial';       # r_id of the initial revision
field '_lwp';           # LWP instance

sub new {
    my $class = shift;
    my $self = {};
    bless $self, $class;

    validate_with(
        params => \@_,
        on_fail => sub {
            chomp (my $p = shift);
            croak $p;
        },
        spec => {
            export => {
                regex => qr/\A $RE{URI} \z/msx
            },
            page => {
                type => SCALAR,
            },
        },
    );

    my %P = @_; # params as hash

    $self->export($P{export});
    $self->page($P{page});

    {
        my $lwp_name;
        eval q{
            use LWPx::ParanoidAgent qw();
        };
        if ($@) {
            $lwp_name = 'LWP::UserAgent';
        } else {
            $lwp_name = 'LWPx::ParanoidAgent';
        };

        $self->_lwp($lwp_name->new);
        $self->_lwp->agent(
            "Mediawiki::Blame/$VERSION (http://search.cpan.org/dist/Mediawiki-Blame/)"
        );
        push @{ $self->_lwp->requests_redirectable }, 'POST';
    };

    $self->ua_timeout(30);  # seconds
    $self->_revisions({});

    $self->_xml_to_revisions(
        $self->_post(
            $self->_post_params({
                after => 1980,  # one revision after 1980, i.e. the initial
                limit => 1,
            })
        )
    );

    $self->_initial(
        [$self->revisions]->[0]->r_id
    );

    $self->_revisions({});  # reset

    return $self;
};

sub _is_now_or_a_datetime {
    my $p = shift;
    if ($p eq 'now') {
        return 1;
    };
    _is_a_datetime($p);
    return 1;
};

sub _is_a_datetime {
    eval {
        DateTime::Format::ISO8601->parse_datetime(shift)
    };
    if ($@) {
        croak substr $@, 0, (index $@, ' at '); # clean up stacktrace
    };
    return 1;
};

sub _is_greater_or_equal_to_2 {
    my $p = shift;
    return ($p =~ /\A $RE{num}{int} \z/msx and $p >= 2);
};

sub _offset {
    my $self = shift;
    my $P    = shift;   # hashref

    for my $k ('before', 'after') {
        if (exists $P->{$k}) {
            Readonly my $STRF => '%FT%TZ';  # 2007-07-23T21:43:56Z
            if (($k eq 'before') and ($P->{$k} eq 'now')) {
                return DateTime->now->strftime($STRF);
            };
            return DateTime::Format::ISO8601
                ->parse_datetime($P->{$k})
                ->strftime($STRF);
        };
    };
};

sub _post_params {
    my $self = shift;
    my $P    = shift;   # hashref

    my $offset = $self->_offset($P);

    my %post_params = (
        pages  => $self->page,
        offset => $offset,
    );

    if (exists $P->{before}) {
        $post_params{dir} = 'desc';
    };

    if (exists $P->{limit}) {
        $post_params{limit} = $P->{limit};
    };

    return \%post_params;
};

sub fetch {
    my $self = shift;

    validate_with(
        params => \@_,
        on_fail => sub {
            chomp (my $p = shift);
            croak $p;
        },
        spec => {
            before => {
                optional  => 1,
                callbacks => {
                    'is now or a datetime' => \&_is_now_or_a_datetime,
                },
            },
            after => {
                optional  => 1,
                callbacks => {
                    'is a datetime' => \&_is_a_datetime,
                },
            },
            limit => {
                optional  => 1,
                callbacks => {
                    'is greater or equal to 2' => \&_is_greater_or_equal_to_2,
                },
            },
        },
    );

    my %P = @_; # params as hash

    if (exists $P{before} and exists $P{after}) {
        croak 'before and after mutually exclusive';
    };

    if (!exists $P{before} and !exists $P{after}) {
        croak 'either before or after needed';
    };

    my ($revision_counter, $revision_duplicates)
        = $self->_xml_to_revisions(
            $self->_post(
                $self->_post_params(\%P)
            )
        );

    return ($revision_counter, $revision_duplicates);
};

sub _xml_to_revisions {
    my $self = shift;
    my $xml  = shift;

    my $revision_counter    = 0;
    my $revision_duplicates = 0;

    eval {
        XML::Twig->new(twig_handlers => {'revision' => sub {
            my $twig = shift;
            my $elt  = shift;

            $revision_counter++;

            my $r_id = $elt->first_child_text('id');

            if (exists $self->_revisions->{$r_id}) {
                $revision_duplicates++;
            } else {
                my $contrib_node = $elt->first_child('contributor');

                my $contributor;
                if ($contrib_node->first_child_text('username')) {
                    $contributor
                        = $contrib_node->first_child_text('username');
                } else {
                    $contributor
                        = $contrib_node->first_child_text('ip');
                };

                $self->_revisions->{$elt->first_child_text('id')} = [
                    $elt->first_child_text('timestamp'),
                    $contributor,
                    [
                        split /(?<=\n)/,    # at line breaks, but don't remove
                        $elt->first_child_text('text')
                    ],
                ];
            };
            $twig->purge;
        }})->parse($xml)->purge
    };

    if ($@) {
# XML::Parser dies, not croaks with some especially dirty error message,
# so I have to do a good scrubbing
        my $e = $@;
        $e = substr $e, 1;  # remove leading "\n"

        croak 'XML parsing failed: '
            . substr $e, 0, (       # clean up stacktrace
            index $e, ' at ', 1+(   # next ' at ' (discard at this position)
                index $e, ' at '    # first ' at ' (keep it)
            )
        );
    };

    return ($revision_counter, $revision_duplicates);
};

sub _post {
    my $self        = shift;
    my $post_params = shift; # hashref

    $self->_lwp->timeout($self->ua_timeout);

    my $response = $self->_lwp->post($self->export, $post_params);
    if (not $response->is_success) {
        croak 'POST request to ' . $self->export . ' failed: '
          . $response->status_line;
    };

    return $response->decoded_content;
};

sub revisions {
    my $self = shift;

    my @r;
    foreach my $r_id (sort {$a <=> $b} keys %{ $self->_revisions }) {
        push @r, Mediawiki::Blame::Revision->_new(
            $r_id,
            @{ $self->_revisions->{$r_id} } # 3 elements
        );
    };

    return @r;
};

sub blame {
    my $self = shift;

    validate_with(
        params => \@_,
        on_fail => sub {
            chomp (my $p = shift);
            croak $p;
        },
        spec => {
            revision => {
                optional => 1,
                callbacks => {
                    'is a valid r_id' => sub {
                        return exists $self->_revisions->{shift()};
                    },
                },
            },
        },
    );

    my %P = @_; # params as hash

    my @r_ids = sort {$a <=> $b} keys %{ $self->_revisions };
    my $last_r_id;
    if ($P{revision}) {
        $last_r_id = $P{revision};
    } else {
        $last_r_id = $r_ids[-1];
    };

    my $ann = Algorithm::Annotate->new;
    for my $r_id (grep {$_ <= $last_r_id} @r_ids) {
        $ann->add(
            $r_id,
            $self->_revisions->{$r_id}[2]     # text
        );
    };

    my @last_revision_text = @{ $self->_revisions->{$last_r_id}[2] };
    my $first_revision     = $r_ids[0];

    return map {
        my $id = $ann->result->[$_];
        if ($id == $first_revision and $id != $self->_initial) {
            Mediawiki::Blame::Line->_new(
                undef,
                $self->_revisions->{$id}->[0],
                undef,
                $last_revision_text[$_],
            );
        } else {
            Mediawiki::Blame::Line->_new(
                $id,
                $self->_revisions->{$id}->[0],
                $self->_revisions->{$id}->[1],
                $last_revision_text[$_],
            );
        };
    } 0..$#last_revision_text;
};

1;
__END__