src/Modules/BZFlag.pl

   1 #!/usr/bin/perl
   2 #
   3 # BZFlag
   4 # Copyright (c) 1993 - 2002 Tim Riker
   5 #
   6 # This package is free software;  you can redistribute it and/or
   7 # modify it under the terms of the license found in the file
   8 # named LICENSE that should have accompanied this file.
   9 #
  10 # THIS PACKAGE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
  11 # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
  12 # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  13
  14 package BZFlag;
  15 use strict;
  16
  17 my $no_BZFlag;
  18
  19 BEGIN {
  20         $no_BZFlag = 0;
  21         eval "use Socket";
  22         eval "use LWP::UserAgent";
  23         $no_BZFlag++ if ($@);
  24 }
  25
  26 sub BZFlag::BZFlag {
  27         my ($message) = @_;
  28   my ($retval);
  29         if ($no_BZFlag) {
  30                 &main::status("BZFlag module requires Socket.");
  31                 return 'BZFlag module not active';
  32         }
  33         if ($message =~ /^bzfquery\s+([^:]*)(?::([0-9]*))?$/xi) {
  34                 $retval = &query($1,$2);
  35         } elsif ($message =~ /^bzflist$/xi) {
  36                 $retval = &list();
  37   } else {
  38                 $retval = "BZFlag: unhandled command \"$message\"";
  39         }
  40         &::performStrictReply($retval);
  41 }
  42
  43 sub BZFlag::list {
  44         my ($response);
  45         my $ua = new LWP::UserAgent;
  46         $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam("httpProxy"));
  47
  48         $ua->timeout(5);
  49
  50         my $req = HTTP::Request->new('GET', 'http://db.bzflag.org/db/?action=LIST');
  51         my $res = $ua->request($req);
  52   my %servers;
  53   my $totalServers = 0;
  54   my $totalPlayers = 0;
  55         for my $line (split("\n",$res->content)) {
  56                 my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5);
  57                 # not "(A4)18" to handle old dumb perl
  58                 my ($style, $maxShots, $shakeWins, $shakeTimeout, $maxPlayerScore, $maxTeamScore, $maxTime,
  59                                 $maxPlayers, $rogueSize, $rogueMax, $redSize, $redMax, $greenSize, $greenMax,
  60                                 $blueSize, $blueMax, $purpleSize, $purpleMax, $observerSize, $observerMax) =
  61                                 unpack("A4A4A4A4A4A4A4A2A2A2A2A2A2A2A2A2A2A2A2A2", $flags);
  62                 my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize)
  63                                 + hex($blueSize) + hex($purpleSize) + hex($observerSize);
  64           $servers{$serverport} = $playerSize;
  65           $totalServers += 1;
  66           $totalPlayers += $playerSize;
  67         }
  68   $response .= "s=$totalServers p=$totalPlayers";
  69   foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) {
  70                 if ($servers{$key} > 0) {
  71                         $response .= " $key($servers{$key})";
  72                 }
  73   }
  74         &::performStrictReply($response);
  75         return;
  76 }
  77
  78 sub BZFlag::list17 {
  79         my ($response);
  80         my $ua = new LWP::UserAgent;
  81         $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam("httpProxy"));
  82
  83         $ua->timeout(5);
  84
  85         my $req = HTTP::Request->new('GET', 'http://list.bzflag.org:5156/');
  86         my $res = $ua->request($req);
  87   my %servers;
  88   my $totalServers = 0;
  89   my $totalPlayers = 0;
  90         for my $line (split("\n",$res->content)) {
  91                 my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5);
  92                 # not "(A4)18" to handle old dumb perl
  93                 my ($style,$maxPlayers,$maxShots,
  94                                 $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
  95                                 $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
  96                                 $shakeWins,$shakeTimeout,
  97                                 $maxPlayerScore,$maxTeamScore,$maxTime) =
  98                                 unpack("A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4", $flags);
  99                 my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize)
 100                                 + hex($blueSize) + hex($purpleSize);
 101           $servers{$serverport} = $playerSize;
 102           $totalServers += 1;
 103           $totalPlayers += $playerSize;
 104         }
 105   $response .= "s=$totalServers p=$totalPlayers";
 106   foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) {
 107                 if ($servers{$key} > 0) {
 108                         $response .= " $key($servers{$key})";
 109                 }
 110   }
 111         &::performStrictReply($response);
 112         return;
 113 }
 114
 115 sub BZFlag::querytext {
 116         my ($servernameport) = @_;
 117         my ($servername,$port) = split(":",$servernameport);
 118         if ($no_BZFlag) {
 119                 &main::status("BZFlag module requires Socket.");
 120                 return 'BZFlag module not active';
 121         }
 122         #my @teamName = ("Rogue", "Red", "Green", "Blue", "Purple");
 123         my @teamName = ("X", "R", "G", "B", "P");
 124         my ($message, $server, $response);
 125         $port = 5155 unless $port;
 126
 127         # socket define
 128         my $sockaddr = 'S n a4 x8';
 129
 130         # port to port number
 131         my ($name,$aliases,$proto) = getprotobyname('tcp');
 132         ($name,$aliases,$port)  = getservbyname($port,'tcp') unless $port =~ /^\d+$/;
 133
 134         # get server address
 135         my ($type,$len,$serveraddr);
 136         ($name,$aliases,$type,$len,$serveraddr) = gethostbyname($servername);
 137         $server = pack($sockaddr, AF_INET, $port, $serveraddr);
 138
 139         # connect
 140         return 'socket() error' unless socket(S1, AF_INET, SOCK_STREAM, $proto);
 141         return "could not connect to $servername:$port" unless connect(S1, $server);
 142
 143         # don't buffer
 144         select(S1); $| = 1; select(STDOUT);
 145
 146         # get hello
 147         my $buffer;
 148         return 'read error' unless read(S1, $buffer, 10) == 10;
 149
 150         # parse reply
 151         my ($magic,$major,$minor,$revision);
 152         ($magic,$major,$minor,$revision,$port) = unpack("a4 a1 a2 a1 n", $buffer);
 153
 154         # quit if version isn't valid
 155         return 'not a bzflag server' if ($magic ne "BZFS");
 156   # try incompatible for BZFlag:Zero etc.
 157         $response = 'incompatible version: ' if ($major < 1);
 158         $response = 'incompatible version: ' if ($major == 1 && $minor < 7);
 159         $response = 'incompatible version: ' if ($major == 1 && $minor == 7 && $revision eq "b");
 160
 161         # quit if rejected
 162         return 'rejected by server' if ($port == 0);
 163
 164         # reconnect on new port
 165         $server = pack($sockaddr, AF_INET, $port, $serveraddr);
 166         return 'socket() error on reconnect' unless socket(S, AF_INET, SOCK_STREAM, $proto);
 167         return "could not reconnect to $servername:$port" unless connect(S, $server);
 168         select(S); $| = 1; select(STDOUT);
 169
 170         # close first socket
 171         close(S1);
 172
 173         # send game request
 174         print S pack("n2", 0, 0x7167);
 175
 176         # get reply
 177         return 'server read error' unless read(S, $buffer, 40) == 40;
 178         my ($infolen,$infocode,$style,$maxPlayers,$maxShots,
 179                 $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
 180                 $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
 181                 $shakeWins,$shakeTimeout,
 182                 $maxPlayerScore,$maxTeamScore,$maxTime) = unpack("n20", $buffer);
 183         return 'bad server data' unless $infocode == 0x7167;
 184
 185         # send players request
 186         print S pack("n2", 0, 0x7170);
 187
 188         # get number of teams and players we'll be receiving
 189         return 'count read error' unless read(S, $buffer, 8) == 8;
 190         my ($countlen,$countcode,$numTeams,$numPlayers) = unpack("n4", $buffer);
 191         return 'bad count data' unless $countcode == 0x7170;
 192
 193         # get the teams
 194         for (1..$numTeams) {
 195                 return 'team read error' unless read(S, $buffer, 14) == 14;
 196                 my ($teamlen,$teamcode,$team,$size,$aSize,$won,$lost) = unpack("n7", $buffer);
 197                 return 'bad team data' unless $teamcode == 0x7475;
 198                 if ($size > 0) {
 199                         my $score = $won - $lost;
 200                         $response .= "$teamName[$team]:$score($won-$lost) ";
 201                 }
 202         }
 203
 204         # get the players
 205         for (1..$numPlayers) {
 206                 last unless read(S, $buffer, 180) == 180;
 207                 my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
 208                                 unpack("n2Nn2 n4A32A128", $buffer);
 209                 return 'bad player data' unless $playercode == 0x6170;
 210                 my $score = $won - $lost;
 211                 $response .= " $sign($teamName[$team]";
 212                 $response .= ":$email" if ($email);
 213                 $response .= ")$score($won-$lost)";
 214         }
 215         $response .= "No Players" if ($numPlayers <= 1);
 216
 217         # close socket
 218         close(S);
 219
 220         return $response;
 221 }
 222
 223 sub BZFlag::query {
 224         my ($servernameport) = @_;
 225         &::performStrictReply(&querytext($servernameport));
 226   return;
 227 }
 228
 229 1;
 230 # vim: ts=2 sw=2