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 use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
  17
  18 my $no_BZFlag;
  19
  20 BEGIN {
  21         $no_BZFlag = 0;
  22         eval "use Socket";
  23         eval "use LWP::UserAgent";
  24         $no_BZFlag++ if ($@);
  25 }
  26
  27 sub BZFlag {
  28         my ($message) = @_;
  29         my ($retval);
  30         if ($no_BZFlag) {
  31                 &::status("BZFlag module requires Socket.");
  32                 return 'BZFlag module not active';
  33         }
  34         if ($message =~ /^bzfquery\s+([^:]*)(?::([0-9]*))?$/xi) {
  35                 $retval = &query($1,$2);
  36         } elsif ($message =~ /^bzflist$/xi) {
  37                 $retval = &list();
  38         } else {
  39                 $retval = "BZFlag: unhandled command \"$message\"";
  40         }
  41         &::performStrictReply($retval);
  42 }
  43
  44 sub list {
  45         my ($response);
  46         my $ua = new LWP::UserAgent;
  47         $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
  48
  49         $ua->timeout(5);
  50
  51         my $req = HTTP::Request->new('GET', 'http://db.bzflag.org/db/?action=LIST');
  52         my $res = $ua->request($req);
  53         my %servers;
  54         my $totalServers = 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                 $servers{$version} += $playerSize;
  66                 $servers{'PLAYERS'} += $playerSize;
  67                 $totalServers += 1;
  68         }
  69         $response .= "s=$totalServers";
  70         foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) {
  71                 if ($servers{$key} > 0) {
  72                         $response .= " $key($servers{$key})";
  73                 }
  74         }
  75         &::performStrictReply($response);
  76         return;
  77 }
  78
  79 sub list17 {
  80         my ($response);
  81         my $ua = new LWP::UserAgent;
  82         $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
  83
  84         $ua->timeout(5);
  85
  86         my $req = HTTP::Request->new('GET', 'http://list.bzflag.org:5156/');
  87         my $res = $ua->request($req);
  88         my %servers;
  89         my $totalServers = 0;
  90         my $totalPlayers = 0;
  91         for my $line (split("\n",$res->content)) {
  92                 my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5);
  93                 # not "(A4)18" to handle old dumb perl
  94                 my ($style,$maxPlayers,$maxShots,
  95                                 $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
  96                                 $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
  97                                 $shakeWins,$shakeTimeout,
  98                                 $maxPlayerScore,$maxTeamScore,$maxTime) =
  99                                 unpack('A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4', $flags);
 100                 my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize)
 101                                 + hex($blueSize) + hex($purpleSize);
 102                 $servers{$serverport} = $playerSize;
 103                 $totalServers += 1;
 104                 $totalPlayers += $playerSize;
 105         }
 106         $response .= "s=$totalServers p=$totalPlayers";
 107         foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) {
 108                 if ($servers{$key} > 0) {
 109                         $response .= " $key($servers{$key})";
 110                 }
 111         }
 112         &::performStrictReply($response);
 113         return;
 114 }
 115
 116 sub querytext {
 117         my ($servernameport) = @_;
 118         my ($servername,$port) = split(":",$servernameport);
 119         if ($no_BZFlag) {
 120                 &::status("BZFlag module requires Socket.");
 121                 return 'BZFlag module not active';
 122         }
 123         #my @teamName = ('Rogue', 'Red', 'Green', 'Blue', 'Purple', 'Observer', 'Rabbit');
 124         my @teamName = ('X', 'R', 'G', 'B', 'P', 'O', 'K');
 125         my ($message, $server, $response);
 126         $port = 5154 unless $port;
 127
 128         # socket define
 129         my $sockaddr = 'S n a4 x8';
 130
 131         # port to port number
 132         my ($name,$aliases,$proto) = getprotobyname('tcp');
 133         ($name,$aliases,$port) = getservbyname($port,'tcp') unless $port =~ /^\d+$/;
 134
 135         # get server address
 136         my ($type,$len,$serveraddr);
 137         ($name,$aliases,$type,$len,$serveraddr) = gethostbyname($servername);
 138         $server = pack($sockaddr, AF_INET, $port, $serveraddr);
 139
 140         # connect
 141         # TODO wrap this with a 5 second alarm()
 142         return 'socket() error' unless socket(S1, AF_INET, SOCK_STREAM, $proto);
 143         return "could not connect to $servername:$port" unless connect(S1, $server);
 144
 145         # don't buffer
 146         select(S1); $| = 1; select(STDOUT);
 147
 148         # get hello
 149         my $buffer;
 150         return 'read error' unless read(S1, $buffer, 8) == 8;
 151
 152         # parse reply
 153         my ($magic,$major,$minor,$something,$revision) = unpack("a4 a1 a1 a1 a1", $buffer);
 154         my ($version) = $magic . $major . $minor . $something . $revision;
 155
 156         # quit if version isn't valid
 157         return 'not a bzflag server' if ($magic ne 'BZFS');
 158         $response .= "$major$minor$something$revision ";
 159         # check version
 160         if ($version eq 'BZFS0026') {
 161                 # 1.11.x handled here
 162                 return 'read error' unless read(S1, $buffer, 1) == 1;
 163                 my ($id) = unpack('C', $buffer);
 164                 return "rejected by server" if ($id == 255);
 165
 166                 # send game request
 167                 print S1 pack('n2', 0, 0x7167);
 168
 169                 # get reply
 170                 my $nbytes = read(S1, $buffer, 4);
 171                 my ($infolen, $infocode) = unpack('n2', $buffer);
 172                 if ($infocode == 0x6774) {
 173                         # read and ignore MsgGameTime from new servers
 174                         $nbytes = read(S1, $buffer, 8);
 175                         $nbytes = read(S1, $buffer, 4);
 176                   ($infolen, $infocode) = unpack('n2', $buffer);
 177                 }
 178                 $nbytes = read(S1, $buffer, 42);
 179                 if ($nbytes != 42) {
 180                         return "Error: read $nbytes bytes, expecting 46: $^E\n";
 181                 }
 182
 183                 my ($style,$maxPlayers,$maxShots,
 184                         $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,$observerSize,
 185                         $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,$observerMax,
 186                         $shakeWins,$shakeTimeout,
 187                         $maxPlayerScore,$maxTeamScore,$maxTime,$timeElapsed) = unpack('n23', $buffer);
 188                 return "bad server data $infocode" unless $infocode == 0x7167;
 189
 190                 # send players request
 191                 print S1 pack('n2', 0, 0x7170);
 192
 193                 # get number of teams and players we'll be receiving
 194                 return 'count read error' unless read(S1, $buffer, 8) == 8;
 195                 my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer);
 196
 197                 # get the teams
 198                 return 'bad count data' unless $countcode == 0x7170;
 199                 return 'count read error' unless read(S1, $buffer, 5) == 5;
 200                 ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer);
 201                 for (1..$numTeams) {
 202                         return 'team read error' unless read(S1, $buffer, 8) == 8;
 203                         my ($team,$size,$won,$lost) = unpack('n4', $buffer);
 204                         if ($size > 0) {
 205                                 my $score = $won - $lost;
 206                                 $response .= "$teamName[$team]:$score($won-$lost) ";
 207                         }
 208                 }
 209
 210                 # get the players
 211                 for (1..$numPlayers) {
 212                         last unless read(S1, $buffer, 175) == 175;
 213                         my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) =
 214                                         unpack('n2Cn5A32A128', $buffer);
 215                         #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
 216                         #               unpack("n2Nn2 n4A32A128", $buffer);
 217                         return 'bad player data' unless $playercode == 0x6170;
 218                         my $score = $won - $lost;
 219                         $response .= " $sign($teamName[$team]";
 220                         $response .= ":$email" if ($email);
 221                         $response .= ")$score($won-$lost)";
 222                 }
 223                 $response .= "No Players" if ($numPlayers < 1);
 224
 225                 # close socket
 226         } elsif ($major == 1 && $minor == 9) {
 227                 # 1.10.x handled here
 228                 $revision = $something * 10 + $revision;
 229                 return 'read error' unless read(S1, $buffer, 1) == 1;
 230                 my ($id) = unpack('C', $buffer);
 231
 232                 # send game request
 233                 print S1 pack('n2', 0, 0x7167);
 234
 235                 # FIXME the packets are wrong from here down
 236                 # get reply
 237                 return 'server read error' unless read(S1, $buffer, 40) == 40;
 238                 my ($infolen,$infocode,$style,$maxPlayers,$maxShots,
 239                         $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
 240                         $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
 241                         $shakeWins,$shakeTimeout,
 242                         $maxPlayerScore,$maxTeamScore,$maxTime) = unpack('n20', $buffer);
 243                 return 'bad server data' unless $infocode == 0x7167;
 244
 245                 # send players request
 246                 print S1 pack('n2', 0, 0x7170);
 247
 248                 # get number of teams and players we'll be receiving
 249                 return 'count read error' unless read(S1, $buffer, 8) == 8;
 250                 my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer);
 251
 252                 # get the teams
 253                 return 'bad count data' unless $countcode == 0x7170;
 254                 return 'count read error' unless read(S1, $buffer, 5) == 5;
 255                 ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer);
 256                 for (1..$numTeams) {
 257                         return 'team read error' unless read(S1, $buffer, 8) == 8;
 258                         my ($team,$size,$won,$lost) = unpack('n4', $buffer);
 259                         if ($size > 0) {
 260                                 my $score = $won - $lost;
 261                                 $response .= "$teamName[$team]:$score($won-$lost) ";
 262                         }
 263                 }
 264
 265                 # get the players
 266                 for (1..$numPlayers) {
 267                         last unless read(S1, $buffer, 175) == 175;
 268                         my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) =
 269                                         unpack('n2Cn5A32A128', $buffer);
 270                         #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
 271                         #               unpack("n2Nn2 n4A32A128", $buffer);
 272                         return 'bad player data' unless $playercode == 0x6170;
 273                         my $score = $won - $lost;
 274                         $response .= " $sign($teamName[$team]";
 275                         $response .= ":$email" if ($email);
 276                         $response .= ")$score($won-$lost)";
 277                 }
 278                 $response .= "No Players" if ($numPlayers < 1);
 279
 280                 # close socket
 281                 close(S1);
 282         } elsif ($major == 1 && $minor == 0 && $something == 7) {
 283                 # 1.7* versions handled here
 284                 # old servers send a reconnect port number
 285                 return 'read error' unless read(S1, $buffer, 2) == 2;
 286                 my ($reconnect) = unpack('n', $buffer);
 287                 $minor = $minor * 10 + $something;
 288                 # quit if rejected
 289                 return 'rejected by server' if ($reconnect == 0);
 290
 291                 # reconnect on new port
 292                 $server = pack($sockaddr, AF_INET, $reconnect, $serveraddr);
 293                 return 'socket() error on reconnect' unless socket(S, AF_INET, SOCK_STREAM, $proto);
 294                 return "could not reconnect to $servername:$reconnect" unless connect(S, $server);
 295                 select(S); $| = 1; select(STDOUT);
 296
 297                 # close first socket
 298                 close(S1);
 299
 300                 # send game request
 301                 print S pack('n2', 0, 0x7167);
 302
 303                 # get reply
 304                 return 'server read error' unless read(S, $buffer, 40) == 40;
 305                 my ($infolen,$infocode,$style,$maxPlayers,$maxShots,
 306                         $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
 307                         $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
 308                         $shakeWins,$shakeTimeout,
 309                         $maxPlayerScore,$maxTeamScore,$maxTime) = unpack('n20', $buffer);
 310                 return 'bad server data' unless $infocode == 0x7167;
 311
 312                 # send players request
 313                 print S pack('n2', 0, 0x7170);
 314
 315                 # get number of teams and players we'll be receiving
 316                 return 'count read error' unless read(S, $buffer, 8) == 8;
 317                 my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer);
 318                 return 'bad count data' unless $countcode == 0x7170;
 319
 320                 # get the teams
 321                 for (1..$numTeams) {
 322                         return 'team read error' unless read(S, $buffer, 14) == 14;
 323                         my ($teamlen,$teamcode,$team,$size,$aSize,$won,$lost) = unpack('n7', $buffer);
 324                         return 'bad team data' unless $teamcode == 0x7475;
 325                         if ($size > 0) {
 326                                 my $score = $won - $lost;
 327                                 $response .= "$teamName[$team]:$score($won-$lost) ";
 328                         }
 329                 }
 330
 331                 # get the players
 332                 for (1..$numPlayers) {
 333                         last unless read(S, $buffer, 180) == 180;
 334                         my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
 335                                         unpack("n2Nn2 n4A32A128", $buffer);
 336                         return 'bad player data' unless $playercode == 0x6170;
 337                         my $score = $won - $lost;
 338                         $response .= " $sign($teamName[$team]";
 339                         $response .= ":$email" if ($email);
 340                         $response .= ")$score($won-$lost)";
 341                 }
 342                 $response .= "No Players" if ($numPlayers <= 1);
 343
 344                 # close socket
 345                 close(S);
 346         } else {
 347                 $response = "incompatible version: $version";
 348         }
 349
 350         return $response;
 351 }
 352
 353 sub query {
 354         my ($servernameport) = @_;
 355         &::performStrictReply(&querytext($servernameport));
 356         return;
 357 }
 358
 359 1;
 360
 361 # vim:ts=4:sw=4:expandtab:tw=80