User:HBC NameWatcherBot/source

This source is released under GFDL. Enjoy.

Note This code uses a version of the MediaWiki module that I repaired, all official versions are not functioning with the current mediawiki servers, so I fixed it. If you wish to reproduce this script you can e-mail me for the repaired mediawiki.pm file. HighInBC ^{(Need help? Ask me)} 03:37, 3 January 2007 (UTC)

# This script is released under the GFDL license
use strict;
use MediaWiki;
use Net::IRC;
use URI::Escape;
use Data::Dumper;
#use Text::DoubleMetaphone qw( double_metaphone );

my $version_number = '0.16b';
my $VERSION = 'HBC NameWatcherBot v'.$version_number.' - Config loads only on change and startup now';
my(@whitelist,@blacklist,%param,$on_server,@job_list,%delayed_names);
my $timing = 0;

## Wiki connection setup
open(PASS,'password');                  # A file with only the password, no carraige return
sysread(PASS, my $password, -s(PASS));  # No password in sourcecode.
close(PASS);
open(USER,'username');                  # A file with only the username, no carraige return
sysread(USER, my $username, -s(USER));  #
close(USER);
warn "Connecting to Wikipedia...\n";
my $c                  =   MediaWiki->new;
$c->setup
                        ({
                          'bot' => {'user' => $username,'pass' => $password},
                          'wiki' => {'host' => 'en.wikipedia.org','path' => 'w'}
                        }) || die "Failed to log in\n";
my $whoami              =  $c->user();
warn "$whoami v$version_number connected\n";

## IRC connection setup

my $server              = 'irc.wikimedia.org';		# The irc server your bot is to reside
my $port                = 6667;				# The port of above mentioned server
my $bot_name            = 'HBC_UWBot';			# The nick for the bot
my @channels            = ('#en.wikipedia');		# The channel(s) to connect to
my $reconnect_delay     = 30;				# Time to wait after disconnect to reconnect (In Seconds)
my $irc = new Net::IRC;					# Net::IRC our master IRC object
warn "Connecting to IRC...\n";
my $conn = $irc->newconn(				#|Connect to the server
                         Nick           => $bot_name,	#|
                         Server         => $server,	#|
                         Port           => $port,	#|
                        );
$conn->add_handler   ('endofmotd'	=> \&on_connect);	# Set off by a connect to server
$conn->add_handler   ('disconnect'	=> \&on_disconnect);	# Set off when connection to server is lost
$conn->add_handler   ('public'		=> \&on_public); 	# Set off by public messages

## General program setup

my(%parameter_expected) =
 (
  'Status'              => 1,
  'Default target'      => 1,
  'Long name'           => 1,
  'Repeating characters' => 1,
  'Repeating numbers' => 1,
  'Write rate'          => 1,
  'Recheck duration'    => 1,
  'Recheck interval'    => 1,
 );
my(@parameter_required) =
 (
  'Status',
  'Default target',
 );
my(%default_params) =
 (
  'Write rate'          => 10,
  'Long name'           => 0,
  'Repeating characters' => 0,
  'Repeating numbers' => 0,
 );

add_job([\&check_parameters,$c],0);
add_job([\&check_whitelist,$c],0);
add_job([\&check_blacklist,$c],0);
add_job([\&debug_report],5);
#add_job([\&check_name,$c,''],6); # for testing strings

## Program loop

while (1)                               # Infinite loop, a serpent biting it's own tail.
  {
  sleep(.1);                             # Important in all infinite loops to keep it calm
  $irc->do_one_loop();
  my (@kept_jobs);                      # A place to put jobs not ready to run yet
  while (my $job = shift(@job_list))    # Go through each job pending
    {
    my($r_job , $timing) = @{$job};
    if ($timing < time())               # If it is time to run it then run it
      {
      if (ref($r_job) eq 'ARRAY')       # Callback style, reference to an array with a sub followed by paramaters
        {
        my $cmd = shift(@{$r_job});
        &{$cmd}(@{$r_job});
        }
      elsif (ref($r_job) eq 'CODE')     # Otherwise just the reference to the sub
        {
        &{$r_job};
        }
      }
    else                                # If it is not time yet, save it for later
      {
      push(@kept_jobs , $job)
      }
    }
  push (@job_list , @kept_jobs);        # Keep jobs that are still pending
  }

sub add_job     # Command to add a job to the queue
  {
  my ($r_job , $timing) = @_;
  push (@job_list , [$r_job , (time()+$timing)]);
  }

#___________________Event_loop_triggered_subs___________________#

sub check_parameters
  {
  warn "Checking parameters...\n";
  my $c = shift;
  AGAIN:
  my $page = $c->get('User:HBC NameWatcherBot/Control panel','r')->content();
  %param = ();
  foreach my $line (split("\n",$page))
    {
    if ($line =~ m|^;(.*?):(.*)$|)
      {
      $param{$1} = $2 if ($parameter_expected{$1});
      }
    }
  unless (lc($param{'Status'}) eq 'on')
    {
    warn "Bot is not turned on in the control panel\n" ;
    warn "\tWaiting 1 minute and trying again";
    sleep 60;
    goto AGAIN;
    }
  foreach my $key (@parameter_required)
    {
    unless ($param{$key})
      {
      warn "Missing required parameter: $key\n";
      warn "\tWaiting 1 minute and trying again";
      sleep 60;
      goto AGAIN;
      }
    }
  %param = (%default_params,%param);
  }

sub check_whitelist
  {
  warn "Checking whitelist...\n";
  my $c = shift;
  my $page = $c->get('User:HBC NameWatcherBot/Whitelist','r')->content();
  @whitelist = ();
  foreach my $line (split("\n",$page))
    {
    push(@whitelist,$1) if ($line =~ m|^;(.*)$|);
    }
  }

sub check_blacklist
  {
  warn "Checking blacklist...\n";
  my $c = shift;
  my $page = $c->get('User:HBC NameWatcherBot/Blacklist','r')->content();
  @blacklist = ();
  foreach my $line (split("\n",$page))
    {
    if ($line =~ m|^;(.*?)(:(.*))?$|)
      {
      my $rh_entry = {};
      ${$rh_entry}{word} = $1;
      if ($2)
        {
        my @flags = split(',',$3);
        ${$rh_entry}{flags} = parse_flags(\@flags);
        }
      push(@blacklist,$rh_entry);
      }
    }
  }

sub parse_flags
  {
  my $ra_flags = shift;
  my %has_flag;
  foreach my $flag (@{$ra_flags})
    {
    if ($flag =~ m|(.*)\((.*)\)|)
      {
      my (@params) = split('\|',$2);
      $has_flag{$1} = \@params;
      }
    else
      {
      $has_flag{$flag} = 1
      }
    }
  return \%has_flag;
  }

sub check_name
  {
  my($c,$name) = @_;
  my $display_name = "'$name'";
  my $master_name = $name;
  warn "Checking name: $display_name\n";
  foreach my $white_word (@whitelist) {$name =~ s|$white_word||gi;} # Remove occurances of whitelisted words
  my $ra_offenses = [];
  foreach my $rh_black_word (@blacklist)
    {
    my $word = ${$rh_black_word}{word};
    if (${$rh_black_word}{flags}{'REGEX'})
      {
      push(@{$ra_offenses},$rh_black_word) if ($name =~ m|$word|i);
      }
    else
      {
      push(@{$ra_offenses},$rh_black_word) if (index(lc($name),lc($word)) > -1);
      }
    }
  add_job([\&bad_name,$c,$master_name,$ra_offenses],0) if
        (
         scalar(@{$ra_offenses}) ||
         (($param{'Long name'}) && (length($name) > $param{'Long name'})) ||
         (($param{'Repeating characters'}) && (detect_repeatition($name,$param{'Repeating characters'}))) ||
         (($param{'Repeating numbers'}) && (detect_repeatition_numbers($name,$param{'Repeating numbers'})))
        );
  return 1;
  }

sub bad_name
  {
  my ($c, $name, $ra_offenses) = @_;
  my(@offense_reports) = ('* {{userlinks|'.$name.'}}');
  my $need_rechecking = 0; # default no reason to report
  my $need_header = 0;
  my $has_edited = user_has_edited($c,$name);
  my $is_blocked = is_blocked($c,$name);
  my $target_page = $param{'Default target'};
  push(@offense_reports,':* This user has edited at least one time.') if ($has_edited);
  if (($param{'Long name'}) && (length($name) > $param{'Long name'}))
    {
    push(@offense_reports, ":* At ".length($name)." characters, this name exceeds ".$param{'Long name'}." characters");
    }
  if (($param{'Repeating characters'}) && (my $char = detect_repeatition($name,$param{'Repeating characters'})))
    {
    push(@offense_reports, ":* This name has the character \"'''".$char."'''\" repeating ".$param{'Repeating characters'}." or more than times in a row.");
    }
  if (($param{'Repeating numbers'}) && (detect_repeatition_numbers($name,$param{'Repeating numbers'})))
    {
    push(@offense_reports, ":* This name has ".$param{'Repeating numbers'}." or more numbers in a row.");
    }
  foreach my $rh_blackword (@{$ra_offenses})
    {
    my $rh_has_flag = ${$rh_blackword}{flags};
    my $label = ((${$rh_has_flag}{'LABEL'}) ? ("called '''".${${$rh_has_flag}{'LABEL'}}[0]."'''") : ("'''${$rh_blackword}{word}'''"));
    my $name_pattern = '('.${$rh_blackword}{word}.')';
    my $match;
    $name =~ m|$name_pattern|i;
    $match = " The portion that matched was '''$1'''." if ($1);
    my(@report) = (((${$rh_has_flag}{'REGEX'}) ? (":* Matches the regular expression $label.$match") : (":* Matches the literal pattern $label.")));
    if  (${$rh_has_flag}{'WAIT_TILL_EDIT'})
      {
      if ($has_edited)
        {
        push (@report, "::* This report was delayed until the user edited.");
        delete($delayed_names{$name});
        }
      else
        {
        warn "\t$name has not edited, not counting match to the string $label at this point, rechecking in $param{'Recheck interval'} seconds.\n";
        $need_rechecking = 1 unless (scalar(@offense_reports) > 1);
        next;
        }
      }
    $need_rechecking = 0;
    warn Dumper
     ({
      'Name'	=> $name,
      'Flags'	=> $rh_has_flag,
      'Word'	=> ${$rh_blackword}{'word'},
     });
    if  (${$rh_has_flag}{'ALTERNATE_TARGET'})
      {
      $target_page = ${${$rh_has_flag}{'ALTERNATE_TARGET'}}[0];
      warn "Alternate target: $target_page\n";
      }
    if  (${$rh_has_flag}{'USE_HEADER'})
      {
      $need_header = 1;
      }
    if  (${$rh_has_flag}{'LOW_CONFIDENCE'})
      {
      push (@report, "::* The string $label is prone to false positives, please take extra care insuring this name is actaully a violation before blocking.");
      }
    if  (${$rh_has_flag}{'NOTE'})
      {
      push (@report, "::* The string $label has a comment associated with it: ".${${$rh_has_flag}{'NOTE'}}[0]);
      }
    if  (${$rh_has_flag}{'SOCK_PUPPET'})
      {
      push (@report, "::* The string $label is often associate with sock puppets of [[User:".${${$rh_has_flag}{'SOCK_PUPPET'}}[0]."]] {{#ifexist:Category:Suspected Wikipedia sockpuppets of ".${${$rh_has_flag}{'SOCK_PUPPET'}}[0]."|(see [[:Category:Suspected Wikipedia sockpuppets of ".${${$rh_has_flag}{'SOCK_PUPPET'}}[0]."]])}}");
      }
    push (@offense_reports,@report);
    }
  if ($need_rechecking)
    {
    $delayed_names{$name} ||= time();
    my $report_age = (time() - $delayed_names{$name});
    if (($report_age > $param{'Recheck duration'}) || ($is_blocked))
      {
      warn "Forgetting about $name, it has been $report_age seconds since creation and no edits.\n";
      warn "\tThe user is blocked you see.\n" if ($is_blocked);
      delete($delayed_names{$name});
      }
    else
      {
      warn "Scheduling recheck of $name\n";
      add_job([\&check_name,$c,$name],$param{'Recheck interval'});
      }
    return 1;
    }
  unshift(@offense_reports, "== Account [[User:$name]] created ==") if $need_header;
  my $report = (join("\n",@offense_reports)." ~~~~\n");
  warn "Writing to: $target_page\n";
  my $page = $c->get($target_page, 'rw');
  if (($page->content() =~ m|<\!-- HBC NameWatcherBot allowed -->|) && !($is_blocked))
    {
    while ($page->{'content'} !~ m|\n\n$|) {$page->{'content'} = $page->{'content'}."\n";}
    $page->{'content'} = ($page->{'content'}.$report);
    $page->{'summary'} = "Reporting [[Special:Contributions/$name|$name]] ([[Special:Blockip/$name|block]]).";
    $page->save();
    warn ($page->{'summary'}."\n");
#    warn ($page->{'content'}."\n\n\n");
    sleep($param{'Write rate'});
    warn "\n";
    }
  elsif ($is_blocked)
    {
    warn "Skipping, user is already blocked.\n";
    }
  else
    {
    warn "I don't have permission to write to '$target_page'\n";
    return;
    }
  }

sub user_has_edited
  {
  my ($c,$name) = @_;
  my $url = 'http://en.wikipedia.org/w/query.php?what=contribcounter&format=xml&titles=User:'.uri_escape($name);
  ($c->{ua}->get($url)->content() =~ m|<count>(\d+)</count>|) || return 0;
  return ($1 > 0);
  }

sub detect_repeatition
  {
  my $string = shift;
  my $limit = shift;
  my $last_char;
  my $current_rep = 1;
  while (my $char = substr($string,0,1,''))
    {
    if ($char eq $last_char)
      {
      $current_rep++;
      }
    else
      {
      $last_char = $char;
      $current_rep = 1;
      }
    return $char if ($current_rep >= $limit);
    }
  return 0;
  }

sub detect_repeatition_numbers
  {
  my $string = shift;
  my $limit = shift;
  my $last_char;
  my $current_rep = 1;
  while (my $char = substr($string,0,1,''))
    {
    if ($char =~ m|^[0-9]$|)
      {
      $current_rep++;
      }
    else
      {
      $current_rep = 0;
      }
    return 1 if ($current_rep >= $limit);
    }
  return 0;
  }

sub is_blocked
  {
  my ($c,$name) = @_;
  my $url = $c->{index}.'?title=Special:Ipblocklist&ip='.uri_escape($name);
  my $data = $c->{ua}->get($url)->content(); # Get blocklist info for user
  return ($data =~ m|</a>\) blocked <a href|)       # If the user is currently blocked
  }

#___________________IRC_triggered_subs___________________#

sub on_connect  # triggered when motd is done... otherwords when you connect to server.
  {
  my $self      = shift;
  my $event     = shift;
  warn "Connected to IRC server '$server:$port' as '$bot_name'.\n";
  foreach my $chan (@channels)
    {
    add_job([\&get_on_channel , $self , lc($chan)] , 0);
    }
  $on_server = 1;
  }

sub get_on_channel
  {
  my $self      = shift;
  my $chan      = shift;

  $chan = lc($chan);
  warn "Attempting to join $chan.\n";
  my $response = $self->join($chan);                                                 # try to join channel
  die("Got join response of: $response\n") unless ($response == 20);
  warn "Joined.\n\n";
  }

sub on_public
  {
  my $self      = shift;
  my $event     = shift;

  my $statement = ${$event->{'args'}}[0];
  my $pattern = chr(0x03).'03(.*?)'.chr(0x03);
  add_job([\&check_name,$c,$1],0) if (($statement =~ m|New user account|) && ($statement =~ "$pattern"));
  add_job([\&check_blacklist,$c],0) if ($statement =~ m|User:HBC NameWatcherBot/Blacklist|);
  add_job([\&check_whitelist,$c],0) if ($statement =~ m|User:HBC NameWatcherBot/Whitelist|);
  add_job([\&check_parameters,$c],0) if ($statement =~ m|User:HBC NameWatcherBot/Control panel|);
  }

sub on_disconnect # triggered when server connection is lost.
  {
  my $self      = shift;
  my $event     = shift;

  my $reason = ${$event->{'args'}}[0];
  warn "Connection lost:".$reason."\n";
  warn "Waiting $reconnect_delay seconds before reconnecting to avoid hammering.\n";
  ($on_server) = (undef , undef);
  sleep($reconnect_delay);      # Avoid getting hammer-blocked by waiting before reconnect.
  warn "Attempting to reconnect to $server:$port\n";
  until ($self->connect()){print "Retry...\n"}  # Start again from the beggining by reconnecting, uses same logfile
  }

#___________________Debug___________________#


sub debug_report
  {
  warn Dumper
   ({
#    'Whitelist'        => \@whitelist,
#    'Blacklist'        => \@blacklist,
    'Params'	=> \%param,
    'Delayed'   => \%delayed_names,
   });
  add_job([\&debug_report],300);
  }