src/FROGS/Command.pm

   1 ##########################################################################
   2 #
   3 #   Copyright (c) 2003 Aymargeddon Development Team
   4 #
   5 #   This file is part of
   6 #   "FROGS" = Framework for Realtime Online Games of Strategy
   7 #
   8 #   FROGS is free software; you can redistribute it and/or modify it
   9 #   under the terms of the GNU General Public License as published by the Free
  10 #   Software Foundation; either version 2 of the License, or (at your option)
  11 #   any later version.
  12 #
  13 #   FROGS is distributed in the hope that it will be useful, but WITHOUT
  14 #   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 #   FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
  16 #   more details.
  17 #   You should have received a copy of the GNU General Public License along
  18 #   with this program; if not, write to the Free Software Foundation, Inc., 675
  19 #   Mass Ave, Cambridge, MA 02139, USA.
  20 #
  21 ###########################################################################
  22 #
  23
  24 #
  25 #  basic command object used by the scheduler
  26 use strict;
  27 use Date::Parse qw(str2time);
  28 use Date::Calc qw(Time_to_Date);
  29 use FROGS::DataBase;
  30 use FROGS::Config qw ($conf);
  31 require "$::conf->{-GAME_NAME}.pm";
  32
  33 package Command;
  34 use Data::Dumper;
  35
  36 sub new {
  37   my ($type, $dbhash, $dbobj)  = @_;
  38
  39   Util::log("$type->new()",2);
  40
  41   my $self = {-dbhash => $dbhash,
  42               -db => $dbobj,
  43               -player => $dbhash->{'PLAYER'},
  44               -game => $dbhash->{'GAME'},
  45               -id => $dbhash->{'ID'},
  46               -location => $dbhash->{'LOCATION'},
  47               -class => $type,
  48              };
  49   bless( $self, $type );
  50
  51   # create an GAME_NAME context object
  52   $self->{-context} = $::conf->{-GAME_NAME}->new($dbhash->{'GAME'},
  53                                                  $dbhash->{'PLAYER'},
  54                                                  $dbobj);
  55
  56   $self->{-speed} = $self->{-context}->get_speed();
  57
  58   # end of the game?
  59   if($self->{-speed} < 0){
  60     Util::log("Game over, no commands anymore!",1);
  61     $self->done();
  62     return 0;
  63   }
  64
  65   # set language according to PLAYER.LANGUAGE
  66   my ($lang) = $dbobj->read_player($self->{-player},'LANGUAGE');
  67   $dbobj->set_language($lang);
  68
  69   $self->{-args} = $self->parse_args( $self->{-dbhash}->{'ARGUMENTS'} );
  70
  71   if (defined  $self->{-dbhash}->{'ACK'} and
  72       $self->{-dbhash}->{'ACK'} ne '0000-00-00 00:00:00'){
  73     $self->{-phase} = 2;
  74   }else{
  75     $self->{-phase} = 1;
  76     $self->{-duration} = $::conf->{-DURATION}->{"-$type"} || 0;
  77   }
  78
  79   if(not $::conf->{-MESSAGE_IN_LOG} and $type eq 'SEND_MSG'){
  80     Util::log('',1);
  81   }else{
  82     my $logstring = "\nCommand $type (ID: $self->{-dbhash}->{'ID'}): ".
  83       "Phase $self->{-phase}, ".
  84         "Player $self->{-dbhash}->{'PLAYER'}, ".
  85           "Game $self->{-dbhash}->{'GAME'}, ".
  86             "Arguments $self->{-dbhash}->{'ARGUMENTS'}";
  87     $logstring .= ", Location $self->{-dbhash}->{'LOCATION'}, "
  88       if defined $self->{-dbhash}->{'LOCATION'};
  89     Util::log($logstring,1);
  90   }
  91
  92   return $self;
  93 }
  94
  95 sub is_valid {
  96   my ($self, @required_args) = @_;
  97
  98   # all arguments avaiable?
  99   # TODO PERFORMANCE: maybe this check only in phase1?
 100   return 0 unless $self->required_args($self->{-args}, @required_args);
 101
 102   # does the player still exists?
 103   if($self->{-player} == -1){
 104     $self->{-role} = $self->{-context}->charname(-1);
 105   }else{
 106     my ($id,$role) = $self->{-context}->read_role($self->{-player},'PLAYER,ROLE');
 107     if($id != $self->{-player}){
 108       Util::log("COMMAND->is_valid: Player $self->{-player} does not exist!\n",0);
 109       return 0;
 110     }
 111     # set role for later use
 112     # print "ROLE(is_valid): $role\n";
 113     $self->{-role} = $role;
 114   }
 115   return 1;
 116 }
 117
 118 sub isSecond {
 119         my $self = shift;
 120         return 2 == $self->{-phase};
 121 }
 122
 123 sub isFirst {
 124         my $self = shift;
 125         return 1 == $self->{-phase};
 126 }
 127
 128 sub execute {
 129   my $self = shift;
 130   my $db=$self->{-db};
 131
 132   #if($self->{-speed} < 0){
 133   #  Util::log('*',-1);
 134   #  $self->done();
 135   #  return;
 136   #}
 137   # determine phase of command and do it.
 138   if ($self->isFirst() ) {
 139     $db->update_hash("COMMAND","ID = $self->{-dbhash}->{'ID'}",{ 'ACK' => $db->now() });
 140     my $ret = $self->first_phase();
 141
 142     if ($self->getDuration() > 0 and $ret > 0) {
 143       my $exec = $self->getPhase2exec();
 144       if($self->{-end_of_game}){
 145         $self->done();
 146       }else{
 147         $db->update_hash("COMMAND",
 148                          "ID = $self->{-dbhash}->{'ID'}",
 149                          { 'EXEC' => $exec });
 150       }
 151     }elsif ($self->getDuration() == 0 or $ret == 0){
 152       $self->done();
 153     } else {
 154       # in this case the command has set its EXEC by itself. we do nothing
 155       $self->done() if $self->{-end_of_game};
 156     }
 157   } elsif ($self->isSecond() ) {
 158     $self->second_phase();
 159     $self->done();
 160   } else {
 161     Util::log("command->execute ($self->{-class}) : Unknown or undefined Command phase",0);
 162     die;
 163   }
 164 }
 165
 166 sub done {
 167 # a command will use this func to declare it's terminated
 168 # it is called by Scheduler after secondPhase anyway, so a
 169 # command has to use it only explicitley in a member if it wants to
 170 # terminate NOW! (but still have to exit action for itself)
 171   my $self = shift;
 172   my $db=$self->{-db};
 173
 174   my $id = $self->{-id};
 175
 176   $db->update_hash("COMMAND","ID = $id",{ 'DONE' => $db->now() });
 177   if ($::conf->{-DEBUG} == 0 or $::conf->{-DELETE_OLD_COMMANDS}) {
 178     $db->delete_from("COMMAND","ID=$id");
 179     Util::log(ref($self)."-Command $id deleted.",1);
 180     # TODO: dont delete PRODUCE-Command if game not runnning, but waiting
 181   }
 182   # TODO?: send messages
 183 }
 184
 185 sub setDuration {
 186 # sets the duration of the command in units. Sheduler will schedule
 187 # the Phase 2 then for gametime+units*pace(game).
 188 # this function will have to be called explicitely during phase 1 by the
 189 # implementation of the command
 190 # If it is not called at least once (or set to 0), Scheduler will assume the command has
 191 # no second phase and will call done() after completion of firstPhase().
 192         my $self = shift;
 193         $self->{-duration} = shift;
 194 }
 195
 196 sub getDuration {
 197 # get command duration in units
 198         my $self = shift;
 199         return $self->{-duration};
 200 }
 201
 202 sub getDurationInSec{
 203 # get command duration in secs according to the *current* gamespeed
 204         my $self = shift;
 205
 206         my $ret = $self->getDuration() *  $self->{-speed};
 207
 208         Util::log("Duration in sec: $ret",1) unless defined $self->{-duration_logged};
 209         $self->{-duration_logged} = 1;
 210
 211         $self->{-end_of_game} = 1 unless $ret >= 0;
 212         return $ret;
 213 }
 214
 215 sub getPhase2exec {
 216         # only valid during phase 1 returns start of phase 2 in game
 217         # time, GMT (YYYY-MM-DD HH:MM:SS). If Duration wasn't set, or
 218         # phase is wrong it returns undef.
 219         my $self = shift;
 220         if ($self->getDuration() == 0 || $self->isSecond() ) {
 221                 return undef;
 222         }
 223         my $firstExecTimeUnix = &::str2time($self->{-dbhash}->{'EXEC'},'GMT');
 224 #       my $firstExecTimeUnix = &::str2time($self->{-dbhash}->{'EXEC'});
 225         $firstExecTimeUnix += $self->getDurationInSec();
 226         my ($year,$month,$day, $hour,$min,$sec) = &::Time_to_Date($firstExecTimeUnix);
 227         return  sprintf ("%04u-%02u-%02u %02u:%02u:%02u",$year,$month,$day, $hour,$min,$sec);
 228 }
 229
 230
 231 #############################################
 232 #
 233 # Tools to be used by concrete commands
 234 #
 235
 236 # TODO: Bug mit messages
 237 sub parse_args {
 238         my ( $self, $arg_string ) = @_;
 239
 240         my @key_value_pairs = split /,/, $arg_string; # TODO: wrong for messages
 241
 242         # remove leading/trailing whitespace
 243         @key_value_pairs = map { $_ =~ s/^\s*(\S*)\s*$/$1/; $_ } @key_value_pairs;
 244
 245         my %hash;
 246         for my $kv (@key_value_pairs) {
 247                 my ( $k, $v ) = split /=/, $kv; # TODO: wrong for messages
 248
 249                 # remove leading/trailing whitespace again
 250                 ( $k, $v ) = map { $_ =~ s/^\s*(\S*)\s*$/$1/; $_ } ( $k, $v );
 251
 252                 $hash{$k} = $v;
 253         }
 254         # use Data::Dumper; print Dumper \%hash;
 255         return \%hash;
 256 }
 257
 258 sub required_args {
 259   my ( $self, $args, @ra ) = @_;
 260
 261   for my $a (@ra) {
 262     unless ( exists $args->{$a} ) {
 263       Util::log("We need argument $a",1);
 264       return 0;
 265     }
 266   }
 267   return 1;
 268 }
 269
 270
 271
 272 # general testfunction.
 273 # sends error message and return false
 274 # unless &$cond() gives true
 275
 276 sub test{
 277   my ($self, $cond, $tag, @args) = @_;
 278
 279   unless(&$cond()){
 280     # (@args) = $self->{-db}->quote_all(@args);
 281
 282     my $sendhash = {'MFROM' => 0,
 283                     'MSG_TAG' => $tag};
 284     # TODO: localize command-strings!
 285     $sendhash->{'ARG1'} = $self->{-class};
 286     for my $a (1..($#args+1)){
 287       $sendhash->{"ARG$a"} = $args[$a-1];
 288     }
 289
 290     $self->{-context}->send_message_to($self->{-player},$sendhash);
 291
 292     Util::log("Test failed: $tag, args @args",1);
 293
 294     return 0;
 295   }
 296   return 1;
 297 }
 298
 299 #sub test{
 300 #  my ($self, @all) = @_;
 301 #
 302 #  if($self->test_without_done(@all)){
 303 #    return 1;
 304 #  }else{
 305 #    # delete me from database
 306 #    $self->done();
 307 #    return 0;
 308 #  }
 309 #}
 310
 311 # set a mobilehash if available, sends errormessage otherwise
 312 sub validate_mobile{
 313   my ($self,$mob_id) = @_;
 314
 315   my $mob = $self->{-db}->read_single_mobile($mob_id);
 316
 317   # mobile correct?
 318   if($self->{-phase} == 1){
 319     return 0 unless $self->test(sub {defined $mob},
 320                                 'MSG_NO_SUCH_MOBILE',
 321                                 $mob_id);
 322   }
 323   $self->{-mob} = $mob;
 324   return 1;
 325 }
 326
 327 # errormessage unless one of valid roles
 328 sub validate_role{
 329   my ($self, @valid_roles) = @_;
 330
 331   return 1 if $self->{-player} < 0;
 332
 333   Util::log("validate_role($self->{-role})",2);
 334
 335   unless(Util::is_in($self->{-role},@valid_roles)){
 336     return 0 unless $self->test(sub {0},
 337                                 'MSG_ROLE_CANT_DO',
 338                                 $self->{-role},
 339                                 ref($self));
 340   }
 341   return 1;
 342 }
 343
 344 sub validate_this_role{
 345   my($self,$player,@valid_roles) = @_;
 346
 347   # fake identity
 348   my $role = $self->{-role};
 349   my ($id,$r) = $self->{-context}->read_role($player,'PLAYER,ROLE');
 350   $self->{-role} = $r;
 351   my $ret = $self->validate_role(@valid_roles);
 352   $self->{-role} = $role;
 353   return 0 unless $ret;
 354   return 1;
 355 }
 356
 357 # takes a mobile_hash, a count and a diff_hash. creates another mobile
 358 # with count members in the database with the different fields given
 359 # in diff_hash. if $available, than the new mob is available
 360
 361 #  returns
 362 # ID of newmob (newmob is in some sense really the old mob, because
 363 # diff is apllied to old mob) , returns the new ID (of the old mob).
 364
 365 sub split_mobile{
 366   my ($self, $mob, $count, $diff, $available) = @_;
 367   my $db = $self->{-db};
 368   Util::log(ref($self).": split mobile $mob->{'ID'}",1);
 369
 370   # create new mobile
 371   my %newmob = %$mob;
 372   my $newmob = \%newmob;
 373   $newmob->{'ID'} = $self->{-db}->find_first_free('MOBILE','ID');
 374   my $newid = $newmob->{'ID'};
 375
 376   %$mob = (%$mob,%$diff);
 377   # print Dumper $mob; exit;
 378   # %$newmob = (%$oldmob, %$newmob);
 379
 380   # calculate new count and available
 381   $mob->{'COUNT'} = $count;
 382   $mob->{'AVAILABLE'} = $available ? 'Y' : 'N';
 383
 384   my $id = $mob->{'ID'};
 385   delete $mob->{'ID'};
 386   # print Dumper $mob;
 387   $self->{-db}->update_hash('MOBILE',"ID=$id",$mob);
 388   Util::log("mobile $id updated",1);
 389
 390   # reduce count of old one
 391   $newmob->{'COUNT'} -= $count;
 392
 393   # print Dumper $newmob;
 394   $self->{-db}->insert_hash('MOBILE',$newmob);
 395   Util::log("new mobile $newid",1);
 396
 397   return $newid;
 398 }
 399
 400 # this function splits a mobile if it necessary, update else.
 401 # usage of parameters: see split_mobile
 402 # returns the new ID of the old mob (see split_mobile)
 403 sub conditional_split_mobile{
 404   my ($self, $mob, $count, $diff, $available) = @_;
 405
 406   # print "count: $count\n";
 407   # print Dumper $mob;
 408
 409   my $db = $self->{-db};
 410
 411   # split it, if neccessary
 412   if($count < $mob->{'COUNT'}){
 413
 414     return $self->split_mobile($mob,$count,$diff,$available);
 415
 416   }elsif($count == $mob->{'COUNT'}){
 417     $diff->{'AVAILABLE'} = $available ? 'Y' : 'N';
 418     $db->update_hash('MOBILE',
 419                      "ID=$mob->{'ID'}",
 420                      $diff);
 421     return $mob->{'ID'};
 422   }else{
 423     Util::log("SPLIT MOBILE: Error! impossible case. not enough mobiles. ".
 424               "we need $count and have only $mob->{'COUNT'}",0);
 425     return 0;
 426   }
 427 }
 428
 429 sub event{
 430   my ($self, $loc, $tag, @args) = @_;
 431
 432   # read execution time
 433   my $exec_time = $self->getPhase2exec();
 434
 435   unless($exec_time){
 436     my $cmd = $self->{-db}->single_hash_select('COMMAND',
 437                                                "ID=$self->{-dbhash}->{'ID'}");
 438     $exec_time = $cmd->{'EXEC'};
 439   }
 440
 441   my $event = {'TAG' => $tag,
 442                'LOCATION' => $loc,
 443                'GAME' => $self->{-game},
 444                'TIME' => $exec_time,
 445                'COMMAND_ID' => $self->{-dbhash}->{'ID'},
 446                };
 447   $event->{'ARG1'} = $self->{-context}->charname($self->{-player});
 448   for my $a (0..$#args){
 449     $event->{'ARG'.($a+2)} = $args[$a];
 450   }
 451   $self->{-db}->write_event($event);
 452 }
 453
 454 # this function re-inserts the same command in the queue again
 455 sub do_it_again{
 456   my ($self,$arguments) = @_;
 457
 458   my $now = $self->{-db}->now();
 459   # we need a new ID
 460   delete $self->{-dbhash}->{'ID'};
 461   # reset timestamps
 462   $self->{-dbhash}->{'SUBMIT'} = $now;
 463   $self->{-dbhash}->{'EXEC'} = $now;
 464   $self->{-dbhash}->{'ACK'} = 'NULL'; # TODO: wrong way to insert NULL?
 465   $self->{-dbhash}->{'DONE'} = 'NULL';
 466   if (defined $arguments){
 467     # these arguments are allready there in the database
 468     my $hash = $self->parse_args($self->{-dbhash}->{'ARGUMENTS'});
 469     # we put some additional ones into hash
 470     for my $k (keys %$arguments){
 471       $hash->{$k} = $arguments->{$k};
 472     }
 473     # rearrange hash into string
 474     my $new_string = '';
 475     my ($key,$value);
 476     while (($key,$value) = each %$hash){
 477       $new_string .= "$key=$value, ";
 478     }
 479     $new_string =~ s/, $//;
 480     $self->{-dbhash}->{'ARGUMENTS'} = $new_string;
 481   }
 482   # write new command to database
 483   $self->{-db}->insert_hash('COMMAND', $self->{-dbhash});
 484 }
 485
 486 1;