src/FROGS/DataBase.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 # Generell database methods are gathered here.
  26 use strict;
  27 use DBI;
  28 use POSIX qw(floor);
  29 use FROGS::Config qw($conf);
  30 use FROGS::Util;
  31 use Date::Parse qw(str2time);
  32 use Date::Calc qw(Time_to_Date Delta_DHMS);
  33
  34 package DataBase;
  35
  36 # the constructor connects to the DB
  37 sub new{
  38   my ($class,$dbh) = @_;
  39   my $self = {};
  40   if (defined $dbh){
  41     $self->{-dbh} = $dbh;
  42   }else{
  43         $self->{-dbh} = DBI->connect("dbi:$::conf->{-DB_SOURCE}",
  44                                        $::conf->{-DB_USER},
  45                                        $::conf->{-DB_PASSWD},
  46                                        {'RaiseError' => 1, 'AutoCommit' => 0}
  47                                                               );
  48   }
  49   #TODO: should specify iso date and time format explicitly for the session!!
  50
  51   $self->{-lang} = $self->{-dbh}->quote($::conf->{-DEFAULT_LANGUAGE});
  52
  53   bless ($self,$class);
  54 }
  55
  56 sub commit{
  57   my $self = shift;
  58   unless(defined $self->{-nowrite}){
  59     $self->{-dbh}->commit();
  60     Util::log('committed.',2);
  61   }
  62 }
  63
  64 sub nowrite{
  65   my $self = shift;
  66   Util::log("DataBase: nowrite activated!",1);
  67   $self->{-nowrite} = 1;
  68 }
  69
  70 # automaticly called destructor
  71 sub DESTROY{
  72   my $self = shift;
  73   $self->{-dbh}->disconnect();
  74 }
  75
  76 # wrapper for database functions:
  77
  78 sub quote{
  79   my ($self, $text) = @_;
  80   return $self->{-dbh}->quote($text);
  81 }
  82
  83 sub quote_all{
  84   my ($self, @plain) = @_;
  85   my @quoted;
  86   for my $s (@plain){
  87     push @quoted, $self->{-dbh}->quote($s);
  88   }
  89   return @quoted;
  90 }
  91
  92 # this does not support any possible SQL-conditions
  93 # just a small subset
  94 # TODO: this function is really ugly :-(
  95 # TODO: just use an escape-character in calls to mark, which fields should be
  96 # TODO: quoted
  97 sub quote_condition{
  98   my ($self, $cond) = @_;
  99
 100   Util::log("condition: $cond",2);
 101
 102   my @bracket = ('(',')');
 103   my @bool = ('AND', 'OR');
 104   my @ops = ('=', '!=');
 105   my @noops = ('<'); # forbidden substrings of pairs. ugly workaround for "time < now()"
 106
 107   # split string at boolean operators
 108   my $splitstring = '';
 109   for my $bool (@bool){
 110     $splitstring .= '\b'.$bool.'\b|';
 111   }
 112   $splitstring =~ s/(.*)\|/$1/;
 113
 114   #Util::log("splitstring: $splitstring\n",2);
 115
 116   my @pairs = split /\s$splitstring\s/, $cond;
 117
 118   Util::log("pairs: @pairs",2);
 119
 120   my $opstring = '';
 121   for my $o (@ops){
 122     $opstring .= "$o|";
 123   }
 124   $opstring =~ s/(.*)\|/$1/;
 125
 126   my $noopstring = '';
 127   for my $no (@noops){
 128     $noopstring .= "$no|";
 129   }
 130   $noopstring =~ s/(.*)\|/$1/;
 131
 132   # quote right hand of operator if necessary
 133   for my $pair (@pairs){
 134     next if $pair =~ /$noopstring/;
 135     my ($left,$right) = split /$opstring/, $pair;
 136     #Util::log("1 left: $left, right: $right",2);
 137     $right =~ s/^\(*-?([\w\s].*)$/$1/; # remove leading brackets
 138     #Util::log("2 left: $left, right: $right",2);
 139     $right =~ s/-?(.*[\w\s])\)*$/$1/; # remove trailing brackets
 140     #Util::log("3 left: $left, right: $right",2);
 141     $right =~ s/^\s*-?(\S.*)/$1/; # remove leading whitespace
 142     #Util::log("4 left: $left, right: $right",2);
 143     $right =~ s/(.*\S)\s*$/$1/; # remove trailing whitespace
 144     #Util::log("5 left: $left, right: $right",2);
 145
 146     next if $right =~ /^\d+$/;
 147     # this could be misfunctional in some SQL-Dialect. We assume single-quotes
 148     my $qright = ($right =~ /^\'.*\'/) ? $right : $self->quote($right);
 149
 150     # Util::log("qright: $qright",2);
 151     next if $cond =~ /$qright/;
 152     $cond =~ s/($opstring\s*)$right/$1$qright/;
 153   }
 154   Util::log("new condition: $cond",2);
 155   return $cond;
 156 }
 157
 158 # assumes that a single row is returned from database
 159 # returns a list of selected columns
 160 sub single_select{
 161   my ($self,$stmt) = @_;
 162
 163   Util::log("single_select: $stmt",2);
 164   my $dat = $self->{-dbh}->selectall_arrayref($stmt);
 165   return () if not defined $dat or not defined $dat->[0];
 166   return @{$dat->[0]};
 167 }
 168
 169 sub single_hash_select{
 170         my ($self,$table,$cond) = @_;
 171
 172         $cond = $self->quote_condition($cond);
 173         my $stmt = "SELECT * FROM $table where $cond";
 174         Util::log("single_hash_select: $stmt",2);
 175         return $self->{-dbh}->selectrow_hashref($stmt);
 176 }
 177
 178 sub select_hash{
 179   my ($self, $table, $key, $fields, $cond) = @_;
 180
 181   my $stmt = $fields ? "SELECT $key, $fields FROM $table"
 182                      : "SELECT $key FROM $table";
 183   $stmt .= " WHERE $cond" if $cond;
 184   return $self->{-dbh}->selectall_hashref($stmt, $key);
 185 }
 186
 187 sub select_array{
 188   my ($self, $table, $fields, $cond, $order) = @_;
 189   my $stmt = "SELECT $fields FROM $table";
 190   if( $cond){
 191     $cond = $self->quote_condition($cond);
 192     $stmt .= " WHERE $cond";
 193     if(defined $order){
 194       $stmt .= " ORDER BY $order";
 195     }
 196   }
 197
 198   Util::log("select_array: $stmt",2);
 199   return $self->{-dbh}->selectall_arrayref($stmt);
 200 }
 201
 202 # returns number of fields with given condition
 203 sub count{
 204   my ($self, $table, $cond) = @_;
 205   my $array = $self->select_array($table,'*',$cond);
 206   my @a = @$array;
 207   my $count = $#a + 1;
 208   Util::log("counted $cond in $table: $count",1);
 209   return $count;
 210 }
 211
 212 # insert a row in one table of the database
 213 #
 214 # parameterlist:
 215 #   table: the database-table we work on
 216 #   hash:  give here a hash with the new values
 217 #   noquote: if hash, than dont quote all keys which are in this hash,
 218 #            if no hash but defined, than we dont quote all the new values
 219 #            (useful for things simmilar to COUNT = COUNT + 1)
 220 sub insert_hash{
 221   my ($self, $table, $hash,$noquote) = @_;
 222   my $noquote_type = ref($noquote);
 223   my $noquote_global = 1 if defined $noquote and not $noquote_type eq 'HASH';
 224   my $noquote_hash = 1 if $noquote_type eq 'HASH';
 225
 226   my $insert = "INSERT INTO $table (";
 227   for my $key (keys %$hash){
 228     # $key = $self->{-dbh}->quote_identifier($key);
 229     $insert .= "$key,";
 230   }
 231   chop($insert);
 232   $insert .=") VALUES (";
 233   while( my ($k,$val) = each %$hash){
 234     $val = $self->quote($val) if not $noquote_global or
 235       ($noquote_hash and exists $noquote->{$k});
 236     $insert .= "$val,";
 237   }
 238   chop($insert);
 239   $insert .= ')';
 240
 241   Util::log("INSERT: $insert",2);
 242   my $h = $self->{-dbh}->prepare($insert);
 243   $h->execute();
 244   $h->finish();
 245 }
 246
 247 # parameter: see insert_hash() and update_hash()
 248 sub insert_or_update_hash{
 249   my ($self, $table, $cond, $hash, $noquote) = @_;
 250   $cond = $self->quote_condition($cond);
 251   my @row = $self->single_select("SELECT * FROM $table WHERE $cond");
 252   use Data::Dumper;
 253   if($#row >= 0){
 254     $self->update_hash($table,$cond,$hash,$noquote);
 255   }else{
 256     $self->insert_hash($table,$hash,$noquote);
 257   }
 258 }
 259
 260 # update a set of rows in one table of the database
 261 #
 262 # parameterlist:
 263 #   table: the database-table we work on
 264 #   cond:  only rows are effected, which evaluates this condition as true
 265 #   hash:  give here a hash with the new values
 266 #   noquote: if hash, than dont quote all keys which are in this hash,
 267 #            if no hash but defined, than we dont quote all the new values
 268 #            (useful for things simmilar to COUNT = COUNT + 1)
 269 sub update_hash{
 270   my ($self, $table, $cond, $hash, $noquote) = @_;
 271   my $noquote_type = ref($noquote);
 272   my $noquote_global = 1 if defined $noquote and not $noquote_type eq 'HASH';
 273   my $noquote_hash = 1 if $noquote_type eq 'HASH';
 274
 275   my $stmt = "UPDATE $table SET ";
 276   while( my ($k,$v) = each %$hash){
 277     $v = $self->quote($v) if not $noquote_global or
 278       ($noquote_hash and exists $noquote->{$k});
 279     $stmt .= "$k=$v,";
 280   }
 281   chop($stmt);
 282
 283   $stmt .= " WHERE ". $self->quote_condition($cond);
 284
 285   Util::log("update_hash: $stmt",2);
 286   my $h = $self->{-dbh}->prepare($stmt);
 287   $h->execute();
 288   $h->finish();
 289 }
 290
 291 sub delete_from{
 292   my ($self,$table,$cond) = @_;
 293
 294   die "do you really want to delete a complete table?" unless $cond;
 295
 296   my $sql = "DELETE FROM $table";
 297   if($cond){
 298     $cond = $self->quote_condition($cond);
 299     $sql .= " WHERE $cond";
 300   }
 301   Util::log($sql,2);
 302   my $dbh = $self->{-dbh};
 303   my $h = $dbh->prepare($sql);
 304   $h->execute();
 305   $h->finish();
 306 }
 307
 308 sub find_first_free{
 309   my ($self,$table,$field) = @_;
 310
 311   my $t = $self->select_array($table, $field);
 312   my @ids = sort {$a <=> $b} (map {$_->[0]} @$t);
 313
 314   my $id = 1;
 315   for my $try (@ids){
 316     next if $try < 0; # unfortunately some tabels contain the id -1 and id 0 is free :-(
 317     last if $id < $try;
 318     $id = $try + 1;
 319   }
 320   return $id;
 321 }
 322
 323 sub read_game{
 324   my ($self,$game,$field) = @_;
 325   my $stmt = "SELECT $field from GAME where GAME=$game";
 326   return $self->single_select($stmt);
 327 }
 328
 329 # localisation
 330
 331 sub set_language{
 332   my ($self, $lang) = @_;
 333   $self->{-lang} = $self->{-dbh}->quote($lang) if $lang;
 334 }
 335
 336 # returns the localisation of a tag.
 337 # if the result contains tags again, localize these too.
 338 sub loc{
 339   my ($self, $tag, @args) = @_;
 340
 341   Util::log("args: @args",2);
 342
 343   $tag = $self->{-dbh}->quote($tag);
 344   my $stmt = 'SELECT TEXT FROM LOCALIZE WHERE LANGUAGE='.$self->{-lang}." AND TAG=$tag";
 345   my ($text) = $self->single_select($stmt);
 346
 347   # replace %x with arg[x]
 348   while($text =~ /\%(\d+)/){
 349     my $nr = $1;
 350     Util::log("found $nr in $text",2);
 351     $text =~ s/(\%$nr)/$args[$nr-1]/g;
 352   }
 353
 354   return $text =~ /^\s*$/ ? "Error: Tag $tag not defined for language $self->{-lang}."
 355     : $self->localize_string($text);
 356 }
 357
 358 # calls loc() for all uppercase-only-words and returns new string
 359 # TODO: allow arguments in brackets after uppercase-words with length >= 3
 360 sub localize_string{
 361   my ($self,$string) = @_;
 362
 363   $string =~ s/(\b[^\Wa-z0-9]{3,}\b)/$self->loc($1)/ge;
 364   return $string;
 365 }
 366
 367 # game management:
 368
 369 sub new_account{
 370   my ($self,$login,$name,$email,$lang) = @_;
 371
 372   my ($qlogin,$qname,$qemail) = $self->quote_all($login,$name,$email);
 373
 374   my $cond = "LOGIN=$qlogin OR REALNAME=$qname OR EMAIL=$qemail";
 375   my $habschon = $self->select_array('PLAYER','PLAYER',$cond);
 376   my @habschon = @$habschon;
 377   return 0 if @habschon;
 378
 379   # generate new password
 380   my $pwd = '';
 381   my $allowed = '2345679ACDEFGHIJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz';
 382   for my $i (0..7){
 383     $pwd .= substr($allowed, POSIX::floor(rand(72)), 1);
 384   }
 385   my $qpwd = $self->{-dbh}->quote($pwd);
 386
 387   # search first free player ID
 388   my $player = $self->find_first_free('PLAYER','PLAYER');
 389
 390   # write new player
 391   $self->insert_hash('PLAYER', {PLAYER   => $player,
 392                                 REALNAME => $name,
 393                                 LOGIN    => $login,
 394                                 EMAIL    => $email,
 395                                 PASSWORD => $pwd,
 396                                 LANGUAGE => $lang,
 397                                });
 398   $self->commit();
 399
 400   my $mail = "From: registration\@aymargeddon.de\nTo: $name <$email>\n"
 401            . "Subject: ".$self->loc('REGISTER_MAIL_SUBJECT')."\n\n"
 402            . $self->loc('REGISTER_MAIL_TEXT', $name, $login, $pwd)."\n";
 403
 404   # print $mail;
 405
 406   open(SENDMAIL, "|mail $email") or Util::log("Can't fork for sendmail: $!",0);
 407   print SENDMAIL $mail;
 408   close(SENDMAIL) or Util::log("sendmail didn't close nicely",0);
 409
 410   return $pwd;
 411 }
 412
 413 sub authenticate{
 414   my ($self, $user, $pwd, $pwd2, $pwd3 ) = @_;
 415
 416   my $admin = $self->quote('admin');
 417   # you can log into any account with adminpassword
 418   my ($adminpwd) = $self->single_select("SELECT PASSWORD FROM PLAYER ".
 419                                         "WHERE LOGIN=$admin");
 420   ($user,$pwd,$adminpwd) = $self->quote_all($user,$pwd,$adminpwd);
 421
 422
 423   # Util::log("Adminpassword: $adminpwd, password: $pwd",2);
 424
 425   my ($player, $sec);
 426   if($adminpwd eq $pwd){
 427     my $stmt = "SELECT PLAYER,SECURITY FROM PLAYER WHERE ".
 428       "LOGIN=$user";
 429     ($player, $sec) = $self->single_select($stmt);
 430   }else{
 431     my $stmt = "SELECT PLAYER,SECURITY FROM PLAYER WHERE ".
 432     "LOGIN=$user AND PASSWORD=$pwd";
 433     ($player, $sec) = $self->single_select($stmt);
 434   }
 435
 436   if($player){
 437     if($pwd2 and $pwd3 and $pwd2 eq $pwd3){
 438       # change password!
 439       $self->update_hash('PLAYER',
 440                          "LOGIN=$user",
 441                          {'PASSWORD' => $pwd2});
 442       Util::log("password changed!",0); # todo: localize and aufhübschen
 443     }
 444     # TODO: write last_login
 445     return $player;
 446   }
 447   return 0;
 448 }
 449
 450 sub write_event{
 451   my ($self, $content) = @_;
 452
 453   $self->insert_hash('EVENT', $content);
 454 }
 455
 456 sub read_event{
 457   my ($self, $id) = @_;
 458
 459   my $e = $self->single_hash_select('EVENT',"ID=$id");
 460   my @args;
 461   for my $a (1..($::conf->{-MAX_ARGS})){
 462     Util::log("search for ARG$a...",2);
 463     push @args, $e->{"ARG$a"};
 464   }
 465
 466   Util::log("args in read_event: @args",2);
 467
 468   my ($loc,$to);
 469   $to = $e->{'LOCATION'} || 'Game';
 470
 471   return ($to,$e->{'TIME'},$self->loc($e->{'TAG'},@args));
 472 }
 473
 474 sub delete_event{
 475   my ($self, $id) = @_;
 476   $self->delete_from('EVENT',"ID=$id");
 477 }
 478
 479 sub send_message{
 480   my ($self, $msg_hash) = @_;
 481
 482   $msg_hash->{'TIME'} = $self->now();
 483   $self->insert_hash('MESSAGE',$msg_hash);
 484 }
 485
 486 sub read_message{
 487   my ($self, $id) = @_;
 488
 489   my $stmt = "SELECT TIME, MFROM, MSG_TAG, MSG_TEXT, ARG1, ARG2, ARG3, ARG4 ".
 490     "FROM MESSAGE WHERE ID=$id";
 491   my ($time, $from, $tag, $text, @args) = $self->single_select($stmt);
 492
 493   # localize it
 494   if($tag){
 495     # print "tag!";
 496     $text = $self->loc($tag, @args);
 497     return ($time, $from, $text, @args);
 498   }elsif($text){
 499     # print "text!";
 500     $text = $self->localize_string($text) unless $from;
 501     return ($time, $from, $text);
 502   }else{
 503     return (0, 'unknown message type error in DataBase');
 504   }
 505 }
 506
 507 sub delete_message{
 508   my ($self, $id) = @_;
 509
 510   $self->delete_from('MESSAGE',"ID=$id");
 511 }
 512
 513 sub read_player{
 514   my ($self,$player,$field) = @_;
 515   my $stmt = "SELECT $field from PLAYER where PLAYER=$player";
 516   return $self->single_select($stmt);
 517 }
 518
 519 # returns all games for id -1 (admin)
 520 sub games_of_player{
 521   my ($self,$player) = @_;
 522
 523   if($player > 0){
 524     return $self->select_array('ROLE','GAME',"PLAYER=$player");
 525   }else{
 526     return $self->select_array('GAME','GAME');
 527   }
 528 }
 529
 530 sub open_games{
 531   my ($self,$cond) = @_;
 532   my $games = $self->select_array('GAME','GAME');
 533
 534   my @log;
 535   for my $game (@$games){
 536       Util::log( Dumper($game)."\n",1);
 537     my $c = "GAME=". $game->[0];
 538     $c .= " AND $cond" if $cond;
 539       Util::log($c."\n",1);
 540     my $unused = $self->select_array('MAP','LOCATION','',$c);
 541
 542     print $unused;
 543
 544       Util::log(Dumper(@$unused),1);
 545
 546     push @log, $game->[0] if @$unused + 1;
 547   }
 548   return \@log;
 549 }
 550
 551 sub read_single_mobile{
 552   my($self,$id) = @_;
 553
 554   return $self->single_hash_select('MOBILE',"ID=$id");
 555 }
 556
 557 sub now{
 558   my $self = shift;
 559   my ($ret) = $self->single_select("SELECT NOW()");
 560   return $ret;
 561 }
 562
 563 # generates a relative time string from an absolute time
 564 sub relative{
 565   my ($self, $absolute) = @_;
 566
 567   my $now = $self->now();
 568   # print "now: $now\nabsolute: $absolute\n";
 569
 570   my $now_unix = Date::Parse::str2time($now,'GMT');
 571   my $absolute_unix = Date::Parse::str2time($absolute,'GMT');
 572   # print "now_unix: $now_unix\nabsolute_unix: $absolute_unix\n";
 573   my $diff = $absolute_unix - $now_unix;
 574
 575   if($diff > 0){
 576
 577     my ($days,$hours,$minutes,$seconds) =
 578       Date::Calc::Delta_DHMS(1970,1,1,0,0,0,Date::Calc::Time_to_Date($diff));
 579
 580     if($days){
 581       return $self->loc('TIME_WITH_DAYS',$days,$hours,$minutes,$seconds);
 582     }elsif($hours){
 583       return $self->loc('TIME_WITH_HOURS',$hours,$minutes,$seconds);
 584     }elsif($minutes){
 585       return $self->loc('TIME_WITH_MINUTES',$minutes,$seconds);
 586     }else{
 587       return $self->loc('TIME_WITH_SECONDS',$seconds);
 588     }
 589   }else{ # $diff <= 0
 590     return '';
 591   }
 592 }
 593
 594 1;
 595
 596