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