File Coverage

blib/lib/Perlwikipedia.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package Perlwikipedia;
2              
3 21     21   634713 use strict;
  21         57  
  21         1011  
4 21     21   120 use warnings;
  21         43  
  21         650  
5 21     21   41771 use WWW::Mechanize;
  21         4604224  
  21         884  
6 21     21   317 use HTML::Entities;
  21         48  
  21         1700  
7 21     21   138 use URI::Escape;
  21         40  
  21         1321  
8 21     21   40301 use XML::Simple;
  0            
  0            
9             use Carp;
10             use Encode;
11             use URI::Escape qw(uri_escape_utf8);
12             use MediaWiki::API;
13              
14             use Module::Pluggable search_path => [ qw(Perlwikipedia::Plugin) ],
15             'require' => 1;
16              
17             foreach my $plugin (__PACKAGE__->plugins) {
18             print "Found plugin $plugin\n";
19             $plugin->import();
20             }
21              
22              
23             our $VERSION = '1.5.2';
24              
25             =head1 NAME
26              
27             Perlwikipedia - a Wikipedia bot framework written in Perl
28              
29             =head1 SYNOPSIS
30              
31             use Perlwikipedia;
32              
33             my $editor = Perlwikipedia->new('Account');
34             $editor->login('Account', 'password');
35             $editor->revert('Wikipedia:Sandbox', 'Reverting vandalism', '38484848');
36              
37             =head1 DESCRIPTION
38              
39             Perlwikipedia is a framework that can be used to write Wikipedia bots.
40              
41             Many of the methods use the MediaWiki API (L).
42              
43             =head1 AUTHOR
44              
45             The Perlwikipedia team (Alex Rowe, Jmax, Oleg Alexandrov) and others.
46              
47             =head1 METHODS
48              
49             =over 4
50              
51             =item new([$agent[, $assert[, $operator]]])
52              
53             Calling Perlwikipedia->new will create a new Perlwikipedia object. $agent sets a custom useragent, $assert sets a parameter for the assertedit extension, common is "&assert=bot", $operator allows the bot to send you a message when it fails an assert. The message will tell you that $agent is logged out, so use a descriptive $agent.
54              
55             =cut
56              
57             sub new {
58             my $package = shift;
59             my $agent = shift || 'Perlwikipedia'; #user-specified agent or default to 'Perlwikipedia'
60             my $assert = shift || undef;
61             my $operator= shift || undef;
62             my $maxlag = shift || 5;
63             if ($operator) {$operator=~s/User://i;} #strip off namespace
64             $assert=~s/\&?assert=// if $assert;
65              
66             my $self = bless {}, $package;
67             $self->{mech} = WWW::Mechanize->new( cookie_jar => {}, onerror => \&Carp::carp, stack_depth => 1 );
68             $self->{mech}->agent("$agent/$VERSION");
69             $self->{host} = 'en.wikipedia.org';
70             $self->{path} = 'w';
71             $self->{debug} = 0;
72             $self->{errstr} = '';
73             $self->{assert} = $assert;
74             $self->{operator}=$operator;
75             $self->{api} = MediaWiki::API->new();
76             $self->{api}->{config}->{api_url} = 'http://en.wikipedia.org/w/api.php';
77             $self->{api}->{config}->{max_lag} = $maxlag;
78             $self->{api}->{config}->{max_lag_delay} = 1;
79             $self->{api}->{config}->{retries} = 5;
80             $self->{api}->{config}->{max_lag_retries} = -1;
81             $self->{api}->{config}->{retry_delay} = 30;
82              
83             return $self;
84             }
85              
86             =item set_highlimits([$flag])
87              
88             Tells Perlwikipedia to start using the APIHighLimits for certain queries.
89              
90             =cut
91              
92             sub set_highlimits {
93             my $self = shift;
94             my $highlimits = shift;
95             unless (defined($highlimits)) {$highlimits=1}
96             $self->{highlimits}=1;
97             }
98              
99             sub _get {
100             my $self = shift;
101             my $page = shift;
102             my $action = shift || 'view';
103             my $extra = shift;
104             my $no_escape = shift || 0;
105              
106             $page = uri_escape_utf8($page) unless $no_escape;
107              
108             my $url =
109             "http://$self->{host}/$self->{path}/index.php?title=$page&action=$action";
110             $url .= $extra if $extra;
111             print "Retrieving $url\n" if $self->{debug};
112             my $res = $self->{mech}->get($url);
113             if ( ref($res) eq 'HTTP::Response' && $res->is_success() ) {
114             if ( $res->decoded_content =~
115             m/The action you have requested is limited to users in the group (.+)\./
116             ) {
117             my $group = $1;
118             $group =~ s/<.+?>//g;
119             $self->{errstr} = qq/Error requesting $page: You must be in the user group "$group"/;
120             carp $self->{errstr} if $self->{debug};
121             return 1;
122             } else {
123             return $res;
124             }
125             } else {
126             $self->{errstr} = "Error requesting $page: " . $res->status_line();
127             carp $self->{errstr} if $self->{debug};
128             return 1;
129             }
130             }
131              
132             sub _get_api {
133             my $self = shift;
134             my $query = shift;
135             print "Retrieving http://$self->{host}/$self->{path}/api.php?$query\n"
136             if $self->{debug};
137             my $res =
138             $self->{mech}->get("http://$self->{host}/$self->{path}/api.php?$query");
139             if ( ref($res) eq 'HTTP::Response' && $res->is_success() ) {
140             return $res;
141             } else {
142             $self->{errstr} = "Error requesting api.php?$query: " . $res->status_line();
143             carp $self->{errstr} if $self->{debug};
144             return 1;
145             }
146             }
147              
148             sub _put {
149             my $self = shift;
150             my $page = shift;
151             my $options = shift;
152             my $extra = shift;
153             my $type = shift;
154             my $res = $self->_get( $page, 'edit', $extra );
155             unless (ref($res) eq 'HTTP::Response' && $res->is_success) { return; }
156             if ( ( $res->decoded_content ) =~ m/