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