main

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5 use Set::Object '&set';
   6
   7 my $delay_between_edits = 60; # In seconds.
   8 my $delay_between_edit_tries = 5;
   9   # Also in seconds. This is the delay taken before trying again
  10   # when an edit fails because of an edit conflict.
  11
  12 my $username = 'UnderBot';
  13 my $password = 'secret';
  14
  15 my $kill_switch_page = 'User talk:UnderBot';
  16 my $kill_switch_trigger = qr/stopediting/i;
  17
  18 my $api_url = 'http://rosettacode.org/mw/api.php';
  19
  20 # ------------------------------------------------------------
  21
  22 package MW;
  23
  24    {use parent 'MediaWiki::API';
  25
  26     my $se = {skip_encoding => 1};
  27
  28     sub couldnt
  29        {my $self = shift;
  30         die
  31             q(Couldn't ),
  32             shift,
  33             '. (', $self->{error}->{code}, ': ',
  34             $self->{error}->{details}, ".)\n";}
  35
  36     sub list
  37        {my $self = shift;
  38         $self->SUPER::list({@_}, $se);}
  39
  40     sub category
  41     # Returns the titles of all the pages in the given category.
  42        {my ($self, $cat) = @_;
  43         map {$_->{title}} @{$self->list
  44            (action => 'query',
  45             list => 'categorymembers',
  46             cmtitle => $cat,
  47             cmlimit => 500)
  48           or $self->couldnt(qq(get members of "$cat"))};}
  49
  50     sub fetch
  51     # Gets the given page with the given title.
  52        {my ($self, $title) = @_;
  53         $self->get_page({title => $title})
  54           or $self->couldnt(q(fetch "$title".));}
  55
  56     sub has_been_deleted
  57     # Has a page with this title ever been deleted?
  58        {my ($self, $title) = @_;
  59         return !! @{$self->list
  60            (action => 'query',
  61             list => 'logevents',
  62             letype => 'delete',
  63             letitle => $title)};}
  64
  65     sub edit_page
  66       # Returns false iff the edit wasn't made because of an edit
  67       # conflict. However, edit conflicts are only checked for if
  68       # appropriate %args are supplied.
  69        {my ($self, $title, %args) = @_;
  70         # Don't touch this page if one by this name has been
  71         # deleted before.
  72         if ($self->has_been_deleted($title))
  73            {print "Didn't edit previously deleted page: $title\n";
  74             return 1;}
  75         # Make the edit.
  76         my $response = $self->SUPER::edit
  77           ({action => 'edit',
  78             title => $title,
  79             minor => 1,
  80             bot => 1,
  81             %args}, $se);
  82         unless ($response)
  83            {if ($self->{error}->{details} =~ /\Aeditconflict/)
  84                {print "Edit conflict: $title\n";
  85                 return 0;}
  86             $self->couldnt(sprintf 'edit page "%s" (%s)',
  87                 $title, join(', ', %args));}
  88         print "Edit: $title",
  89             ($args{summary} ? " ($args{summary})" : ''),
  90             "\n";
  91         # Now sleep for a bit and check the kill switch.
  92         sleep $delay_between_edits;
  93         $self->fetch($kill_switch_page)->{'*'} =~ $kill_switch_trigger
  94             and die "Killed.\n";
  95         return 1;}
  96
  97     sub modify_page
  98       # A way to edit a page that guards against edit conflicts.
  99       # $function should modify $_ (which will contain the
 100       # text of the page) and return the edit summary.
 101        {my ($self, $title, $function) = @_;
 102         for (;;)
 103            {my $page = $self->fetch($title);
 104             my $timestamp = $page->{timestamp} || 0;
 105             my $text = $page->{'*'};
 106             local *_ = \$text;
 107             my $summary = $function->();
 108             $self->edit_page($title,
 109                 text => $text,
 110                 summary => $summary,
 111                 basetimestamp => $timestamp)
 112               and last;
 113             sleep $delay_between_edit_tries;}}}
 114
 115 package main;
 116
 117 # ------------------------------------------------------------
 118
 119 # Set up.
 120
 121 binmode STDOUT, ':utf8';
 122 print 'Starting: ', scalar localtime, "\n";
 123
 124 my $mw = new MW({api_url => $api_url});
 125
 126 $mw->login({lgname => $username, lgpassword => $password})
 127     or $mw->couldnt('log in');
 128
 129 # Get existing languages.
 130
 131 my $langs = set
 132     grep {$_ ne 'HQ9+'} # Hardly a real language.
 133     map {/\ACategory:(.+)/ ? $1 : ()}
 134     $mw->category('Category:Programming Languages');
 135
 136 # Add any new languages that Rosetta Coders have used as arguments
 137 # to Template:Mylang.
 138
 139 my @users =
 140   grep {$_->{type} eq 'edit' or $_->{type} eq 'new'}
 141     # We don't care about log entries, deletions, etc.
 142   @{$mw->list
 143    (action => 'query',
 144     list => 'recentchanges',
 145     rcnamespace => 2, # User
 146     rclimit => 500)}
 147   or $mw->couldnt('get recent changes');
 148
 149 foreach my $u (@users)
 150    {my $p = $mw->fetch($u);
 151     exists $p->{'*'} or next;
 152     foreach ($p->{'*'} =~ /{{mylang\|(.+?)\|/g)
 153        {$_ = ucfirst;
 154         $langs->has($_) || m/#/ and next;
 155           # Nasty things happen if we try to create a page with
 156           # a pound sign in its title.
 157         $mw->edit_page("Category:$_",
 158             appendtext => '{{language}}{{stub}}',
 159             summary => "Created language observed in [[$u]].");
 160         $langs->insert($_);}}
 161
 162 # Create language-user, not-implemented,
 163 # examples-needing-attention, and language-implementation pages.
 164
 165 foreach
 166        (['Category:Language users',
 167             'Category:%s User',
 168             '{{langgroup|%s}}'],
 169         ['Category:Unimplemented tasks by language',
 170             'Reports:Tasks not implemented in %s',
 171             '{{Unimpl Page|%s}}'],
 172         ['Category:Examples needing attention',
 173             'Category:%s examples needing attention',
 174             '{{enacat body|%s}}'],
 175         ['Category:Language Implementations',
 176             'Category:%s Implementations',
 177             '{{implementation cat|%s}}'])
 178    {my ($cat, $title_fmt, $body_fmt) = @$_;
 179     (my $r = quotemeta $title_fmt) =~ s/\\%s/(.+)/;
 180     my $catlangs = set
 181         map {/\A$r\z/ ? $1 : ()}
 182         $mw->category($cat);
 183
 184     foreach (@{$langs - $catlangs}) # Set difference
 185        {$mw->edit_page(sprintf($title_fmt, $_),
 186             appendtext => sprintf($body_fmt, $_));}}
 187
 188     #my ($a, $b) = (-1, -1);
 189     #while (++$a < @langs and ++$b < @catlangs)
 190     #   {$langs[$a] eq $catlangs[$b] and next;
 191     #    if ($catlangs[$b] lt $langs[$a])
 192     #       {--$a;
 193     #        next;}
 194     #    $create->($langs[$a]);
 195     #    --$b;}
 196     # $create->($_) foreach @langs[$a .. $#langs];}
 197
 198 # For each category C in Category:Alternate_language_names, move
 199 # all members of C to the redirect target named in the page for C.
 200 # We assume that the members of C are included in C via
 201 # Template:Header, as opposed to an explicit wikilink to C.
 202
 203 foreach my $cat ($mw->category('Category:Alternate language names'))
 204    {my $catpage = $mw->fetch($cat)->{'*'};
 205     $catpage =~ /#REDIRECT\s+\[\[:?Category:(.+?)\]\]/
 206         or die "Regex didn't match in $cat";
 207     my $target = $1;
 208     my $alt = quotemeta substr $cat, length 'Category:';
 209     # We'll be using $alt as a regex. It should permit underscores
 210     # in place of spaces, since MediaWiki does.
 211     $alt =~ s/\\ /[ _]/;
 212     foreach my $task ($mw->category($cat))
 213        {$mw->modify_page($task, sub
 214            {s <== \{\{ header \| ($alt) ([|}])>
 215               <=={{header|$target$2>xg
 216                 or print "Failed to remove $task from $cat.\n";
 217             qq("header|$1" -> "header|$target");});}}
 218
 219 # Finish.
 220
 221 print 'Done: ', scalar localtime, "\n";