XCore.pm


package XSTAB::RTCW::XCore;
# RTCW core game module
# By default, RTCW doesn't log much of interest,
# So you'll probably want to install Shrub and
# use the XShrub module instead
#
# $Id: XCore.pm,v 1.17 2003/03/27 04:50:22 dranok Exp $
#
# This module is released under the GPL
# Author: DranoK
# Email: dranok@users.sourceforge.net
# Documentation: http://xstab.sourceforge.net
################################################


NAME

XSTAB::RTCW::XCore


DESCRIPTION

This is the core RTCW module. It can be used with a default RTCW server. There is no support for gibs/revives/etc.


INITIALIZATION

use XSTAB::XData;
use XSTAB::RTCW::XCoreCommands;
use strict;

my $VERSION = 0.9;

# These are events found in the RTCW log file
# Most log entries are simply ignored, but those
# which are important are designated in this hash,
# as well as a regex to pull the appropriate data
my %event;
$event{Kill} = "([0-9]+) ([0-9]+) [0-9]+: .* by (.*)";
# killer, victim, mod
$event{ClientUserinfoChanged} = "(.*)";
# client, name, team
#$event{ClientDisconnect} = "([0-9]+)";  # <-- See comments where event would be parsed
# client
$event{InitGame} = "(.*)";
# irrelevant
$event{score} = "([0-9]+) +ping: ([0-9]+) +client: ([0-9]+) (.*)";
# score, ping, client, name
$event{ExitLevel} = "(.*)";
# data
$event{say} = "(.*): *([^:]+)\$";
# name, text
$event{ClientConnect} = "([0-9]+)";
# client


PUBLIC METHODS REQUIRED BY API

In order to write your own game module, you MUST impliment the following methods.

create ()
This constructor will return the blessed object after creating a command object as $self->{command}
sub create
{
  my $class = shift;

  my $self = { };
  $self->{command} = XSTAB::RTCW::XCoreCommands->create;
  
  bless($self, $class);
  return $self;
}

pre_loop_hook ()
This method is provided in case anyone finds a need for it in their game module. Currently I do not take advantage of it.
sub pre_loop_hook
{
  return;
}

post_loop_hook ()
This method is provided in case anyone finds a need for it in their game module. Currently I do not take advantage of it.
sub post_loop_hook
{
  return;
}

get_status ()
This method returns a who's online list. The debug module uses this method for the 'status' command.
sub get_status
{
  my $self = shift;

  my $loaded;
  my $unloaded;
  foreach my $client (keys %Players) {
    if ($Players{$client}{has_loaded}) {
      $loaded .= "$client: $Players{$client}{name} [$Players{$client}{guid}]$Global{sp}";
    } else {
      $unloaded .= "$client: $Players{$client}{name}$Global{sp}";
    }
  }
  $unloaded =~ s/$Global{sp}$//;
  return "Loaded players:$Global{sp}$loaded$Global{sp}Unloaded players:$Global{sp}$unloaded";
}

sensor_command (string ID)
This method returns the command a particular sensor module should execute, such as 'status' or 'pb_sv_plist', or in XShrub, 'plist'
sub sensor_command
{
  my $self = shift;
  my $id = shift;

  if ($id eq 'XUdp') {
    return "status$Global{sp}pb_sv_plist";
  } elsif ($id eq 'XTail') {
    return;
  } elsif ($id < 0) {
    do_log("Sensor data error", 3);
  } else {
    do_log("Input from ID $id not recognized.", 3);
  }
}

do_log (string Message, int Priority)
This is the overloaded do_log function. Purpose is to identify which module is logging the message
sub do_log
{
  my $string = shift;
  my $prio = shift;
  XSTAB::XData::do_log("RTCW::Xcore: $string", $prio);
}

process_data (string rawdata)
This method parses the data returned by the sensor modules, hopefully doing something useful with it.
sub process_data
{
  my $self = shift;
  my $rawdata = shift;
  
  if ($rawdata < 0) {
    do_log("Sensor Error", 3);
    return -1;
  } elsif (!$rawdata) {
    return;
  }

  my @data = split($Global{sp2}, $rawdata);
  my $status;
  my $pbplist;
  my $tail;
  
  foreach my $line (@data) {
    my ($id, $dataline) = split($Global{sp}, $line);
    if ($id eq 'status') {
      $status .= $dataline;
    } elsif ($id eq 'pb_sv_plist') {
      $pbplist .= $dataline;
    } elsif ($id eq 'tail') {
      $tail .= $dataline;
    } else {
      do_log("Unknown ID: $id", 2);
    }
  }
  
  my @tailar = split('\n', $tail);
  foreach my $tail_elem (@tailar) {
    if ($tail_elem =~ /^ *([0-9]+:[0-9]+) *([a-zA-Z]+)[: ] *(.*)/) {
      my $timestamp = $1;
      my $eventtype = $2;
      my $misc = $3;
      if(defined($event{$eventtype})) {
        my @tokens = ( $misc =~ /$event{$eventtype}/ );
        $self->parse_event($eventtype, @tokens);
      } else {
        do_log("UNMATCHED: $tail_elem", 5);
      }
    } else {
      do_log("UNMATCHED: $tail_elem", 5);
    }
  }

  my @statusar = split('\n', $status);
  foreach my $status_elem (@statusar) {
    if ($status_elem =~ /^ *([0-9]+) +[0-9\-]+ +([0-9]+) +(.*) +[0-9]+ +([0-9]+\.[0-9]+\.[0-9]+\.[0-9]+):([\-0-9])+ +[0-9]+ +[0-9]+ *$/)
    { # It's a valid status line
      my $client = $1;
      my $oldip = $Players{$client}{ip}; # Sanity check
      $Players{$client}{ping} = $2;
      $Players{$client}{rawname} = $3;
      $Players{$client}{ip} = $4;
      $Players{$client}{port} = $5;
      if ($oldip && ($oldip ne $Players{$client}{ip})) { # New player?!
        delete $Players{$client};
        next;
      }
      $Players{$client}{name} = $self->stripstring($Players{$client}{rawname});
      if (!$Players{$client}{has_loaded}) {
        $self->check_load($client);
      }
      do_log("MATCHED: $status_elem", 5);
    } elsif ($status_elem =~ /^map: ([^ ]+)/) {
      $Global{map} = $1;
    } else {
      do_log("UNMATCHED: $status_elem", 5);
    }
  }         

  my @pbplistar = split('\n', $pbplist);
  foreach my $pb_elem (@pbplistar) {
    if ($pb_elem =~ /PunkBuster Server: +([0-9]+) +([a-z0-9]+)[^ ]+ +([0-9]+\.[0-9]+\.[0-9]+\.[0-9]+):([0-9\-]+) +[a-zA-Z]+ +[0-9]+ +[0-9\.]+ +[0-9]+ +\((.)\) +(.*) */)
    { # It's a valid pb_sv_plist
      my $pbid = $1;
      my $client = $pbid - 1;
      $Players{$client}{pbid} = $1;
      $Players{$client}{guid} = $2;
      $Players{$client}{os} = $5;
      if (!$Players{$client}{has_loaded}) {
        $self->check_load($client);
      }
      do_log("MATCHED: $pb_elem", 5);
#      my $ip = $3;
#      my $port = $4;
#      my $name = $6;
    } else {
      do_log("UNMATCHED: $pb_elem", 5);
    }
  }
}


PUBLIC METHODS (NOT REQUIRED BY API)

These methods are NOT required in your own game modules, they are merely convenient to use in this specific module.

parse_event (string EventType, array Tokens)
This method will figure out what to do with a specific event.
sub parse_event
{
  my $self = shift;
  my $eventtype = shift;
  my @tokens = @_;

  if ($eventtype eq 'Kill') {
    if ($Players{$tokens[0]}{has_loaded} && $Players{$tokens[1]}{has_loaded}) {
      if ($Players{$tokens[0]}{team} eq $Players{$tokens[1]}{team}) {
        if ($tokens[0] eq $tokens[1]) {
          $Players{$tokens[0]}{suicides}++;
          $Players{$tokens[0]}{mod_suicides}{$tokens[2]}++;
        } else {
          $Players{$tokens[0]}{tks}++;
          $Players{$tokens[0]}{tkscore} -= 3;
          $Players{$tokens[0]}{last_tkd} = $tokens[1];
          $Players{$tokens[1]}{tkdeaths}++;
          $Players{$tokens[1]}{tkd_by}{$tokens[0]}++;
          $self->check_kick($tokens[0]);
        }
      } else {
        $Players{$tokens[0]}{kills}++;
        $Players{$tokens[0]}{tkscore}++;
        $Players{$tokens[0]}{r_kills}++;
        $Players{$tokens[0]}{mod_kills}{$tokens[2]}++;
        $Players{$tokens[1]}{deaths}++;
        $Players{$tokens[1]}{r_deaths}++;
        $Players{$tokens[1]}{mod_deaths}{$tokens[2]}++;
      }
    } else {
      do_log("Kill event, one participant not loaded.", 4);
    }
  } elsif ($eventtype eq 'ClientUserinfoChanged') {
    $tokens[0] =~ /([0-9]+) +n\\(.*)\\t\\[0-9]+\\model\\([^\/]+)\/.*/;
    my $client = $1;
    my $team = $3;
    # As soon as they connect, RTCW assumes a player is on axis.  This makes sure their guid is set
    # before their team, essencially ignoring this first ClientUserinfoChanged.  This makes sure
    # spectators don't load
    if ($Players{$client}{guid}) {
      $Players{$1}{team} = $3;
    }
    # Name = $1
  } elsif ($eventtype eq 'ClientDisconnect') {
    if ($Players{$tokens[0]}{has_loaded}) {
      $Players{$tokens[0]}{last_played} = time;
      $main::storage->save_player_hash($tokens[0]);
    }
    $self->remove_player($tokens[0]);
  } elsif ($eventtype eq 'InitGame') {
    # At the present moment, I see no need to do nothing here.
    # You would want to determine if the new round is real or
    # a warmup here were you to decide to turn warmup damage on 
  } elsif ($eventtype eq 'score') {
    $Players{$tokens[2]}{game_score} = $tokens[0];
    $Players{$tokens[2]}{total_ping} += $tokens[1];
    $Players{$tokens[2]}{ping_size}++;
  } elsif ($eventtype eq 'ExitLevel') {
    foreach my $client (keys %Players) {
      if ($Players{$client}{has_loaded}) {
        $Players{$client}{rounds}++;
        $Players{$client}{last_played} = time;
        $main::storage->save_player_hash($client);
      } else {
        do_log("I will not save unloaded player $client: $Players{$client}{name}", 4);
      }
      $self->reset_rstats($client);
    }
  } elsif ($eventtype eq 'say') {
    # Do say shit
    # name, text
    my $client = $self->find_player_by_name($tokens[0]);
    if ($client < 0) {
      do_log("Say event not recorded, find_player_by_name failed", 4);
    } else {
      do_log("$Players{$client}{name} said '$tokens[1]'", 5);
      $self->{command}->parse_command($client, $tokens[1]);
    }
#  } elsif ($eventtype eq 'ClientConnect') {
#    $self->remove_player($tokens[0]);
#    Found out that this happens every friggin round
#    shrub uses uConnect which is better
#    Leaving this commented in case someone wants to know WHY I don't match this
  } else {
    do_log("Unmatched event: $eventtype", 3);
  }
}

check_kick (int ClientID)
This method will determine if a player needs to be kicked for TK problems.
sub check_kick
{
  my $self = shift;
  my $client = shift;
  
  if ($Players{$client}{tkscore} <= 0 && !$self->{command}->check_flags($Players{$client}{admin_flags}, 'z')) {
    $self->{command}->do_cmd("clientkick $client", 100); 
    $self->{command}->do_say("$Players{$client}{rawname} has been kicked by XStab for TK problems");
  }
}

find_player_by_name (string Name)
This method will return the ClientID of a full stripped name.
sub find_player_by_name
{
  my $self = shift;
  my $name = shift;
  my $newname = $self->stripstring($name);
  
  my $matches = 0;
  my $match;
  foreach my $client (keys %Players) {
    if ($Players{$client}{name} eq $newname) {
      $matches++;
      $match = $client;
    }
  }
  if ($matches > 0) {
    if ($matches > 1) {
      do_log("find_player_by_name failed, multiple matches on $name", 3);
      return -1;
    } else {
      do_log("find_players_by_name found exactly one match ($match) for $name", 5);
      return $match;
    }
  } else {
    do_log("find_players_by_name failed, no match found on $name", 3);
    return -2;
  }
}

reset_rstats (int ClientID)
This method will delete all elements in a player's hash starting with 'r_'
sub reset_rstats
{
  my $self = shift;
  my $client = shift;
  
  foreach my $stat (keys %{$Players{$client}}) {
    if ($stat =~ /^r_/) {
      delete $Players{$client}{$stat};
    }
  }
}

remove_player (int ClientID)
This method simply deletes the specified player's hash record.
sub remove_player
{
  my $self = shift;
  my $client = shift;
  delete $Players{$client};
}

check_load (int ClientID)
This method will determine if a player is 'loaded'. I consider a player loaded when i have their GUID, name, and their team. After this happens kills/etc can be recorded.
sub check_load
{
  my $self = shift;
  my $client = shift;

  if ($Players{$client}{name} =~ /[a-zA-Z0-9]/) {
    if (length($Players{$client}{guid}) == 32) {
      if ($Players{$client}{team}) {
        do_log("$Players{$client}{name} has loaded.", 3);
        $Players{$client}{has_loaded} = 1;
        $main::storage->load_player_hash($client);
        $self->{command}->add_admin_flags($client);
        $Players{$client}{tkscore} = 5;
      } else {
        do_log("$Players{$client}{name} could not be loaded: no team set.", 3);
      }
    } else {
      do_log("$Players{$client}{name} could not be loaded: invalid GUID.", 3);
    }
  } else {
    do_log("Client $client could not be loaded: No valid name found.", 3);
  }  
} 

stripstring (string String)
This method strips color codes/wierd characters from player names. This stops them from fscking up the bot. :)
sub stripstring
{
  my $self = shift;
  my $string = shift;

  $string =~ s/\^.//g;
  $string =~ s/[^A-Za-z0-9]+//g;
  return $string;
}

1;


AUTHOR

This module was coded by DranoK and is part of the core XStab modules. You may directly contact DranoK at dranok@users.sourceforge.net, or by posting to the forums at:

        http://www.oltl.net/forums/forumdisplay.php?s=&forumid=25