Main code

edit
# This script is released under the GFDL license, see
# http://en.wiki.x.io/w/index.php?title=User:HBC Archive Indexerbot/source&action=history
# for a full list of contributors

### Configuration ###
# Time to sleep between writes (in seconds)
my $write_delay = 5;
# Max pages to download at once
my $download_max = 25;

# Default template
my $default_template = 'User:HBC Archive Indexerbot/default template';

# Cache paths
my $cache = 'cache';
my $wiki_cache = "$cache/wiki";
my $obj_cache = "$cache/obj";
my $report_cache = "$cache/reports";
### End Configuration ###

use strict;
use warnings;
use Data::Dumper;
use Date::Parse;
use Digest::SHA1 qw(sha1_hex);
use Encode qw(decode_utf8 encode_utf8);
use HTML::Entities qw(encode_entities);
use IO::Socket;
use MediaWiki;
use POSIX qw(strftime);
use Storable;
use Time::Duration;
use Time::Local;
use URI::Escape;
use XML::Simple;


my($log_file,$pages_watched,$pages_downloaded,$pages_attempted,$dl,$ul) = ('',0,0,0,0,0);
my $nowiki = 'nowiki';
my $start_time = undef;
#########################################
# Log into Wikipedia                    #
#########################################
die "Cache directories must be created in advance\n" unless (-d $cache && -d $wiki_cache && -d $obj_cache);
open(PASS,'password');                  # A file with only the password, no carraige return
sysread(PASS, my $password, -s(PASS));  # No password in sourcecode.
close(PASS);
writelog                  ('Connecting to Wikipedia');
my $c                  =   MediaWiki->new;
$c->setup
                        ({
                          'bot' => {'user' => 'HBC Archive Indexerbot','pass' => $password},
                          'wiki' => {'host' => 'en.wiki.x.io','path' => 'w'}
                        }) || die 'Failed to log in';
my $whoami              =  $c->user();
writelog                 ($whoami.' connected');

#########################################
# Update cache to modern state          #
#########################################
writelog                 ('Gathering jobs');
my @master_job_list     =  gather_jobs();
my @post_jobs           = @master_job_list;


writelog                  (scalar(@master_job_list).' jobs found');
writelog                 ('Parsing cache');
my $rh_cache_data       =  parse_cache();
writelog                 ('done');
writelog                 ('Parsing watchlist');
my $rh_modified_data    =  parse_watchlist();
writelog                 ('done');
download_pages(find_updated());
download_pages(find_templates(@master_job_list));
#push                     (@needed,&find_holes());
                           fetch_pages(@master_job_list);
writelog                 ("$pages_watched pages added to watchlist.");
writelog                 ("$pages_downloaded out of $pages_attempted downloaded.");
#########################################
# Parse cached data and create reports  #
#########################################

writelog ('Creating reports');
foreach my $ra_job (@post_jobs) {
  my $page = decode_utf8(encode_utf8($ra_job->{'page'}));
  my $dest = decode_utf8(encode_utf8($ra_job->{'target'}));
  my $dest_escaped = _escape($dest);
  my $mask = decode_utf8(encode_utf8(join(', ', @{$ra_job->{'mask'}})));
  my $index_here = $ra_job->{'indexhere'};
  unless (check_text(1000,$dest_escaped))
    {
    writelog ('Not writing to [['.$dest.']] as I cannot find permission (sourced from: [['.$page.']])');
    next;
    }
  my $report = create_report($ra_job);
  open(REPORT, ">$report_cache/$dest_escaped.$$");
  use bytes;
  print REPORT $report;
  close(REPORT);
  if (-e "$report_cache/$dest_escaped") {
    my $result = `diff --brief "$report_cache/$dest_escaped" "$report_cache/$dest_escaped.$$"`;
    unless ($result) {
      writelog ('No change, skipping [['.encode_entities($dest).']]');
      unlink "$report_cache/$dest_escaped.$$";
      next;
    }
  }
  $c->login();
  writelog ('Writing report at [['.encode_entities($dest).']]');
  my $edit_summary = "Writing index of archives in " . encode_entities($mask) . " due to request from [[ " . encode_entities($page) . "]] - Bot edit";
  my $result = send_report($dest,$report,$edit_summary);
  if ($result) {
      rename "$report_cache/$dest_escaped.$$", "$report_cache/$dest_escaped";
  } else {
      unlink("$report_cache/$dest_escaped.$$");
  }
}

$ul += 120 + length($log_file);
writelog ('Complete, downloaded {{formatnum:'.int($dl/1024).'}} kilobyte(s) and uploaded {{formatnum:'.int($ul/1024).'}} kilobyte(s) (figures approximate)');
&post_log();
exit;

#########################################
# Subroutines                           #
#########################################

sub check_text {
  my $bytes = shift;
  my $page = shift;

  my $host = 'en.wiki.x.io';
  my $path = "/w/index.php?title=$page&action=raw";
  my $sock         = new IO::Socket::INET
      (
       PeerAddr    => $host,
       PeerPort    => 80,
       Proto       => 'tcp',
      );
  return 0 unless ($sock);
  my $header = ('GET http://'.$host.$path.' HTTP/1.1'."\r\n".'User-Agent: HBC Archive Indexerbot 0.9a'."\r\n\r\n");
  syswrite ($sock, $header);
  my($buf , $content, $done);
  while (!$done)
    {
    ($done = 1) unless sysread($sock, $buf, $bytes);
    $content .= $buf;
    if ((length($content) >= $bytes) || ($content =~ m|!-- HBC Archive Indexerbot can blank this --|))
      {
      $done = 1;
      }
    }
  close($sock);
  $dl += length($content);
  return ($content =~ m|!-- HBC Archive Indexerbot can blank this --|);
}

sub create_report {
  my ($ra_job) = @_;
  my ($rh_index, $numbered_links) = index_headings($ra_job);
  my $template = get_template($ra_job->{'template'});
  my $report = sprintf("%sThis report has been generated because of a request at [[%s]]. It covers the archives that match '''%s'''\n<br/>Report generated at ~~~~~ by ~~~\n----\n\n",
                       $template->{'lead'}, $ra_job->{'page'}, join(', ', @{$ra_job->{'mask'}}));
  $report .= $template->{'header'};
  my $i = 0;
  foreach my $key (sort {lc($a) cmp lc($b) || $rh_index->{$a}->{'root_path'} cmp $rh_index->{$b}->{'root_path'}} (keys(%{$rh_index}))) {
    $rh_index->{$key}->{'topic'} =~ s:({{.*?}}|[|!]{2}):<$nowiki>$1</$nowiki>:g;
    my $row = $template->{'row'};
    if ($template->{'altrow'}) {
      unless ($i++ % 2 == 0) {
        $row = $template->{'altrow'}
      }
    }
    foreach ('topic','replies','link','first','last','duration',
             'firstepoch','lastepoch','durationsecs') {
      $row =~ s:%%$_%%:${$rh_index}{$key}{$_}:gi;
    }
    $report .= $row;
  }
  $report .= sprintf("%s\n%s", $template->{'footer'}, $template->{'tail'});
  return $report;
}

sub download_pages {
  my (@pages) = @_;
  return unless @pages;
  my $requests = scalar(@pages);

  my (@received_names);

  while (@pages) {
    my @batch;
    while ((scalar(@batch) < 50) && @pages) {
      my $item = shift(@pages) || last;
      $item = _underscore($item);
      push (@batch, $item);
    }
    $pages_attempted += scalar(@batch);
    my $xml_code = $c->special_export(@batch);
    $dl += length($xml_code);
    my $xml_result = XMLin($xml_code);
    next unless ($xml_result->{'page'});
    if ($xml_result->{'page'}{'title'}) {
      push (@received_names, handle_chunk($xml_result->{'page'}));
    } else {
      foreach my $key (keys %{$xml_result->{'page'}}) {
        push (@received_names, handle_chunk($xml_result->{'page'}->{$key}));
      }
    }
  }
  writelog('Downloaded '.scalar(@received_names)." pages from $requests requests");
  return (@received_names);
}

sub fetch_pages {
  my (@jobs) = @_;

  my (@cache_names) = keys(%$rh_cache_data);
  foreach my $ra_job (@jobs) {
    my @fetch;

    if ($ra_job->{'indexhere'}) {
      my $page = _underscore($ra_job->{'page'});
      push(@fetch, $ra_job->{'page'}) unless (defined($rh_cache_data->{$page}));
    }

    my $fetch_size = 0;
    foreach my $mask (@{$ra_job->{'mask'}}) {
      if ($mask =~ m|<#>|) {
        $fetch_size += 10;
        my $pattern = _underscore($mask);
        my ($part1, $part2) = split(m|<#>|, $pattern, 2);
        $pattern = qr/\Q$part1\E(\d+)/;
        $pattern .= qr/\Q$part2\E/ if $part2;
        my $leading_zeros = $ra_job->{'leading_zeros'}+1;
        my $marker = '%d';
        $marker = '%0'.$leading_zeros.'d' if ($leading_zeros > 1);
        my $printf_pattern = $mask;
        $printf_pattern =~ s|<#>|$marker|;
        my (@mask_pages) = grep(/^$pattern/,@cache_names);
        my $largest = 0;
        foreach my $key (@mask_pages) {
          ($key =~ m|$pattern|) || next;
          $largest = $1 if ($1 > $largest);
        }
        my $count = $largest;
        my (@pages);
        until ($count >= ($largest + $fetch_size)) {
          $count++;
          my $page_name = sprintf($printf_pattern, $count);
          push(@fetch,$page_name);
        }
      # MONTHLY: elsif here for the <date> or whatever is used
      } else {
        my $check = _underscore($mask);
        push (@fetch, $mask) unless (defined($rh_cache_data->{$check}));
      }
    } continue {
      if (scalar(@fetch)) {
        my (@received) = download_pages(@fetch);
        $rh_cache_data = parse_cache();
        (@cache_names) = keys(%$rh_cache_data);
        if (scalar(@fetch) == scalar(@received)) {
          @fetch = ();
          redo;
        } else {
          @fetch = ();
        }
      }
      $fetch_size = 0;
    }
  }
}

sub find_holes  # This sub will find gaps in the archive(mabye a page was deleted then restored) and
  {             # adds them to the list of potentially needed pages
  return();
  }

sub find_templates {
  my (@jobs) = @_;
  my %templates;
  my @templates_needed;
  foreach my $ra_job (@jobs) {
    $templates{$ra_job->{'template'}}++;
  }
  foreach my $template (keys %templates) {
    $template = $default_template if $template eq 'default';
    my $tmpl_under = _underscore($template);
    push(@templates_needed, $template) unless defined($rh_cache_data->{$tmpl_under});
  }
  writelog (scalar(@templates_needed).' templates needed');
  return @templates_needed;
}

sub find_updated # Find items that have changed
  {
  my(@need_update);
  foreach my $page (keys(%{$rh_cache_data})) {
    if ($rh_modified_data->{$page}) { # If it's not on the watchlist, it hasn't
                                      # been modified in the past month, ignore
      if ($rh_cache_data->{$page} < ${$rh_modified_data}{$page}) {
        push(@need_update,$page);
        my $fname = ("$wiki_cache/".uri_escape_utf8($page).' '.$rh_cache_data->{$page});
        unlink($fname); # Remove old item
      }
    }
  }
  writelog (scalar(@need_update).' pages need updating');
  return @need_update;
  }

sub gather_jobs
  {
  my (@jobs);
  my $html_list         =  $c->{ua}->get($c->{index}."?title=Special:Whatlinkshere/User:HBC Archive Indexerbot/OptIn&limit=5000")->content();
  $dl += length($html_list);
  my @targets;
  while ($html_list =~ s|>([^<]*?)</a> \(transclusion\)||)
    {
    push(@targets,$1);
    }
  my $xml_source = XMLin($c->special_export(@targets));
  my $xml = $xml_source;
  $dl += length($xml_source);
  my $rh_pages = ${$xml}{'page'};
  my %targets;
  foreach my $key (keys(%{$rh_pages})) {
    my $content = ${$rh_pages}{$key}{'revision'}{'text'}{'content'};
    if ($content =~ m"\Q{{User:HBC Archive Indexerbot/OptIn\E\s*\|(.+?)\s*\Q}}\E"s) {
      my @params = split(/\s*\|\s*/, $1);
      my %job = ( page => $rh_pages->{$key}{'title'}, leading_zeros => 0 );
      foreach my $param (@params) {
        my ($key, $value) = split(/\s*=\s*/, $param);
        next unless ($key && defined($value));

        $value =~ s:^\.?/:$job{'page'}/:;

        if ($key eq 'target') {
          $job{'target'} = $value;
        } elsif ($key eq 'mask') {
          next unless $value;
          push (@{$job{'mask'}}, $value);
        } elsif ($key =~ /leading_zeroe?s/) {
          if ($value =~ m/^(\d+)$/) {
            $job{'leading_zeros'} = $1;
          }
        } elsif ($key eq 'indexhere') {
          $job{'indexhere'} = (($value =~ m|ye?s?|i) ? ('1') : ('0'));
        } elsif ($key eq 'template') {
          $job{'template'} = $value;
        }

      }
      $job{'template'} = 'default' unless $job{'template'};
      $job{'template'} = 'default' if $job{'template'} eq 'template location';

      next unless ($job{'target'} && $job{'mask'});

      if ($targets{$job{'target'}}) {
        writelog("Request on [[$job{'page'}]] duplicates target [[$job{'target'}]]; skipping");
        next;
      } else {
        $targets{$job{'target'}}++;
      }

      push(@jobs,\%job);
    }
  }
  return @jobs;
  }

sub get_template {
  my ($template) = (@_);

  if ($template eq 'default') {
    $template = $default_template;
  }

  my $tmpl_fn = _escape($template);
  my ($file) = glob("$wiki_cache/$tmpl_fn*");
  unless ($file) {
    if ($template eq $default_template) {
      die "$template missing from cache\n";
    } else {
      return get_template('default');
    }
  }
  open(TMPL, $file);
  my @content = <TMPL>;
  close(TMPL);

  my %template = (lead => '', header => '', row => '', altrow => '',
                  footer => '', tail => '');
  my $section = '';
  foreach my $line (@content) {
    chomp $line;
    if ($line =~ m:^<!--\s*(.*?)\s*-->$:) {
      $section = lc($1);
      $section =~ s/\s+//g;
      last if $section eq 'end';
    } else {
      if ($section) {
        next unless $line;
        $template{$section} .= "$line\n";
      }
    }
  }
  $template{'lead'} .= "\n" if $template{'lead'};

  unless ($template{'row'}) {
    die "Default template missing 'row' parameter!\n" if $template eq $default_template;
    writelog("Invalid template: '$template', using default instead");
    return get_template('default');
  }

  return \%template;
}

sub handle_chunk {
  my $chunk = shift;
  my $name = _underscore(${$chunk}{'title'});
  my $fname = "$wiki_cache/".uri_escape_utf8($name);
  ${$chunk}{'revision'}{'timestamp'} =~ m|(\d{4})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})Z|;
  my $time = timegm($6,$5,$4,$3,$2-1,$1);
  watch($name) unless (${$rh_cache_data}{$name});
  open(OUT,">$fname $time");
  binmode(OUT);
  use bytes;
  print OUT (${$chunk}{'revision'}{'text'}{'content'});
  no bytes;
  close(OUT);
  $pages_downloaded++;
  return $name;
}

sub index_headings {
  my ($ra_job) = @_;

  my $mask_re = '';
  foreach my $mask (@{$ra_job->{'mask'}}) {
    my $mask2 = _escape($mask);
    if ($mask2 =~ m|%3C%23%3E|) {
      my ($part1, $part2) = split(m|%3C%23%3E|, $mask2, 2);
      $mask_re .= '(?:';
      $mask_re .= qr/\Q$part1\E\d+/;
      $mask_re .= qr/\Q$part2\E/ if $part2;
      $mask_re .= ')|';
    # MONTHLY: elsif here for <date>
    } else {
      $mask_re .= qr/\Q$mask2\E/.'|';
    }
  }
  chop($mask_re);

  opendir(CACHE,$wiki_cache);
  my(@cache) = readdir(CACHE);
  closedir(CACHE);
  my @files = grep(m|^(?:$mask_re)|,@cache);
  if ($ra_job->{'indexhere'}) {
    my $page = _escape($ra_job->{'page'});
    push(@files, grep(m|^\Q$page\E \d+$|,@cache));
  }
  my (%index, %used_headings);
  my $numbered_links = 0;
  foreach my $file (@files) {
    my (%used_names);
    next unless ($file =~ m|^(.*) (\d+)$|);
    my $root_path = decode_utf8(uri_unescape($1));
    my $display_name = $root_path;
    $display_name =~ s/_/ /g;
    open(WIKI, "$wiki_cache/$file");
    my @content = <WIKI>;
    close(WIKI);
    my $prev_heading = '';
    my ($comment_count,$first,$last) = (0,0,0);
    foreach my $line (@content) {
      if ($line =~ m|^==\s*([^=].+?)\s*==|) {
        if ($prev_heading && $comment_count > 0) {
          ## WARNING: This code is duplicated below vvvvvv
          $index{$prev_heading}->{'replies'} = $comment_count;
          if ($first && $last) {
            $index{$prev_heading}->{'firstepoch'} = $first;
            $index{$prev_heading}->{'first'} = strftime('%F %T',gmtime($first));
            $index{$prev_heading}->{'lastepoch'} = $last;
            $index{$prev_heading}->{'last'} = strftime('%F %T', gmtime($last));
            $index{$prev_heading}->{'durationsecs'} = $last - $first;
            if ($comment_count > 1) {
              $index{$prev_heading}->{'duration'} = duration($last - $first);
            } else {
              $index{$prev_heading}->{'duration'} = 'None';
            }
          }
          $comment_count = 0;
          $first = 0;
          $last = 0;
        }
        my $heading = $1;
        my $head_link;
        ($head_link, $numbered_links) = path_fix($heading, $numbered_links);
        $used_names{lc($head_link)}++;
        my $suffix = (($used_names{lc($head_link)} > 1) ? ('_'.$used_names{lc($head_link)}) : (''));
        $used_headings{lc($head_link.$suffix)}++;
        $prev_heading = $head_link.$suffix.'_'.$used_headings{lc($head_link.$suffix)};
        $index{$prev_heading} = { topic => encode_entities(decode_utf8($heading)), link => ("[[{{urlencode:$root_path}}#$head_link".$suffix."|$display_name]]"),
                                  root_path => $root_path, head_link => $head_link,
                                  replies => 'Unknown', first => 'Unknown',
                                  'last' => 'Unknown', duration => 'Unknown',
                                  firstepoch => 0, lastepoch => 0,
                                  durationsecs => 0,
                                };
      } elsif ($line =~ m/\[\[User.*[\]>)}].*?\s+(.*\(UTC\))/) {
        $comment_count++;
        my $time = str2time($1);
        if ($time && (!$first || $time < $first)) {
          $first = $time;
        }
        if ($time && ($time > $last)) {
          $last = $time;
        }
      }
    }
    if ($prev_heading && $comment_count > 0) {
      ## WARNING: This code is duplicated from above ^^^^^^
      $index{$prev_heading}->{'replies'} = $comment_count;
      if ($first && $last) {
        $index{$prev_heading}->{'firstepoch'} = $first;
        $index{$prev_heading}->{'first'} = strftime('%F %T', gmtime($first));
        $index{$prev_heading}->{'lastepoch'} = $last;
        $index{$prev_heading}->{'last'} = strftime('%F %T', gmtime($last));
        $index{$prev_heading}->{'durationsecs'} = $last - $first;
        if ($comment_count > 1) {
          $index{$prev_heading}->{'duration'} = duration($last - $first);
        } else {
          $index{$prev_heading}->{'duration'} = 'None';
        }
      }
    }
  }
  return \%index;
}

sub parse_cache
  {
  my (@pages,$count);
  opendir(CACHE,$wiki_cache);
  my(@files) = readdir(CACHE);
  closedir(CACHE);
  my(%cache);
  foreach my $file (@files)
    {
    next unless ($file =~ m|^(.*) (\d+)$|);
    my $page_name = decode_utf8(uri_unescape($1));
    my $time = $2;
    $cache{$page_name} = $time;
    }
  return \%cache;
  }

sub parse_watchlist
  {
  my $watchlist         =  $c->{ua}->get($c->{index}."?title=Special:Watchlist&days=0")->content();
  $dl += length($watchlist);
  my @lines             =  split("\n",$watchlist);
  my @date;
  my %watchlist;
  while (scalar(@lines))
    {
    my $line = shift(@lines);
    if ($line =~ m|<h4>(\d{4})-(\d{2})-(\d{2})</h4>|i)
      {
      @date = ($1,$2,$3);
      }
    if ($line =~ m|title="([^"]*?)">hist</a>|i) # "
      {
      my $page_name = _underscore($1);
      $line =~ m|(\d{2}):(\d{2}):(\d{2})|;
      $watchlist{$page_name} = timegm($3,$2,$1,$date[2],$date[1]-1,$date[0]);
      }
    }
  return \%watchlist;
  }

sub path_fix {
  my ($path,$numbered_links) = @_;
  ($path =~ s|'{2,4}||g);
  ($path =~ s|<.*?>||g);
  ($path =~ s/\[\[:?.*?\|(.*?)\]\]/$1/g);
  ($path =~ s|\[\[:?(.*?)\]\]|$1|g);
  while ($path =~ m|\[.*?\]|) {
    my $title;
    if ($path =~ m|\[[^ ]* (.*?)\]|) {
      $title = $1;
    } else {
      $numbered_links++;
      $title = ".5B$numbered_links.5D";
    }
    $path =~ s|\[.*?\]|$title|;
  }
  ($path =~ s|\s|_|g);
  ($path =~ s| |.C2.A0|g);
  while ($path =~ m|([^/a-z0-9\.:_'-])|i) {
    my $bad = $1;
    my $fix = uc('.'.sprintf("%x",ord($bad)));
    ($path =~ s/\Q$bad/$fix/g);
  }
  return ($path,$numbered_links);
}

sub post_log {
  my $pg                =  $c->get('User:HBC Archive Indexerbot/logs', 'rw');
  $pg->{summary}        =  ('Writing log file for '.$start_time).' - Bot edit';
  $pg->{content}        =  $log_file;
  $pg->save();
}

sub send_report {
  my $dest      = shift;
  my $report    = shift;
  my $edit_summary = shift;
  my $pg        = $c->get($dest, 'w');
  $pg->{summary}        =  $edit_summary;
  $pg->{content}        =  '<!-- HBC Archive Indexerbot can blank this -->'."\n".$report;
  $ul += length($report);
  my $result = $pg->save();
  unless ($result) {
      my $dest_entities = encode_entities($dest);
      writelog("Failed to save report to $dest_entities");
  }
  sleep($write_delay);
  return $result;
}

sub watch
  {
  my $page_name = shift;
  my $success = $c->{ua}->get($c->{index}."?title=$page_name&action=watch")->is_success;
  $pages_watched++ if ($success);
  return $success;
  }

sub writelog {
  my $entry = shift;
  my @month_table =
  (
   'January',
   'February',
   'March',
   'April',
   'May',
   'June',
   'July',
   'August',
   'September',
   'October',
   'November',
   'December',
  );
  my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime(time);
  my $time = sprintf("%02d:%02d:%02d %02d %s %04d", $hour,$min,$sec,$mday,$month_table[$mon],($year+1900));
  $start_time ||= $time;
  $log_file .= ('* '.$time.': '.$entry.' ~~~'."\n");
  warn "$entry\n";
}

sub _escape {
  my ($val) = @_;
  $val = _underscore($val);
  $val = uri_escape_utf8($val);
  return $val;
}

sub _hash {
  my ($val) = @_;
  $val = _escape($val);
  $val = sha1_hex($val);
  return $val;
}

sub _underscore {
  my ($val) = @_;
  $val =~ s|\s|_|g;
  return $val;
}
 

MediaWiki Change

edit

Fixing an error in MediaWiki/page.pm (forgotten &):

return $obj->{ua}->get($obj->_wiki_url . "&action=" . ($unwatch ? "un" : "") . "watch")->is_success;