1 ##########################################################################
3 # Copyright (c) 2003 Aymargeddon Development Team
6 # "FROGS" = Framework for Realtime Online Games of Strategy
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)
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
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.
21 ###########################################################################
25 # Generell database methods are gathered here.
29 use FROGS::Config qw($conf);
31 use Date::Parse qw(str2time);
32 use Date::Calc qw(Time_to_Date Delta_DHMS);
36 # the constructor connects to the DB
38 my ($class,$dbh) = @_;
43 $self->{-dbh} = DBI->connect("dbi:$::conf->{-DB_SOURCE}",
45 $::conf->{-DB_PASSWD},
46 {'RaiseError' => 1, 'AutoCommit' => 0}
49 #TODO: should specify iso date and time format explicitly for the session!!
51 $self->{-lang} = $self->{-dbh}->quote($::conf->{-DEFAULT_LANGUAGE});
58 unless(defined $self->{-nowrite}){
59 $self->{-dbh}->commit();
60 Util::log('committed.',2);
66 Util::log("DataBase: nowrite activated!",1);
67 $self->{-nowrite} = 1;
70 # automaticly called destructor
73 $self->{-dbh}->disconnect();
76 # wrapper for database functions:
79 my ($self, $text) = @_;
80 return $self->{-dbh}->quote($text);
84 my ($self, @plain) = @_;
87 push @quoted, $self->{-dbh}->quote($s);
92 # this does not support any possible SQL-conditions
94 # TODO: this function is really ugly :-(
95 # TODO: just use an escape-character in calls to mark, which fields should be
98 my ($self, $cond) = @_;
100 Util::log("condition: $cond",2);
102 my @bracket = ('(',')');
103 my @bool = ('AND', 'OR');
104 my @ops = ('=', '!=');
105 my @noops = ('<'); # forbidden substrings of pairs. ugly workaround for "time < now()"
107 # split string at boolean operators
108 my $splitstring = '';
109 for my $bool (@bool){
110 $splitstring .= '\b'.$bool.'\b|';
112 $splitstring =~ s/(.*)\|/$1/;
114 #Util::log("splitstring: $splitstring\n",2);
116 my @pairs = split /\s$splitstring\s/, $cond;
118 Util::log("pairs: @pairs",2);
124 $opstring =~ s/(.*)\|/$1/;
128 $noopstring .= "$no|";
130 $noopstring =~ s/(.*)\|/$1/;
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);
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);
150 # Util::log("qright: $qright",2);
151 next if $cond =~ /$qright/;
152 $cond =~ s/($opstring\s*)$right/$1$qright/;
154 Util::log("new condition: $cond",2);
158 # assumes that a single row is returned from database
159 # returns a list of selected columns
161 my ($self,$stmt) = @_;
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];
169 sub single_hash_select{
170 my ($self,$table,$cond) = @_;
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);
179 my ($self, $table, $key, $fields, $cond) = @_;
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);
188 my ($self, $table, $fields, $cond, $order) = @_;
189 my $stmt = "SELECT $fields FROM $table";
191 $cond = $self->quote_condition($cond);
192 $stmt .= " WHERE $cond";
194 $stmt .= " ORDER BY $order";
198 Util::log("select_array: $stmt",2);
199 return $self->{-dbh}->selectall_arrayref($stmt);
202 # returns number of fields with given condition
204 my ($self, $table, $cond) = @_;
205 my $array = $self->select_array($table,'*',$cond);
208 Util::log("counted $cond in $table: $count",1);
212 # insert a row in one table of the database
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)
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';
226 my $insert = "INSERT INTO $table (";
227 for my $key (keys %$hash){
228 # $key = $self->{-dbh}->quote_identifier($key);
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});
241 Util::log("INSERT: $insert",2);
242 my $h = $self->{-dbh}->prepare($insert);
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");
254 $self->update_hash($table,$cond,$hash,$noquote);
256 $self->insert_hash($table,$hash,$noquote);
260 # update a set of rows in one table of the database
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)
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';
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});
283 $stmt .= " WHERE ". $self->quote_condition($cond);
285 Util::log("update_hash: $stmt",2);
286 my $h = $self->{-dbh}->prepare($stmt);
292 my ($self,$table,$cond) = @_;
294 die "do you really want to delete a complete table?" unless $cond;
296 my $sql = "DELETE FROM $table";
298 $cond = $self->quote_condition($cond);
299 $sql .= " WHERE $cond";
302 my $dbh = $self->{-dbh};
303 my $h = $dbh->prepare($sql);
309 my ($self,$table,$field) = @_;
311 my $t = $self->select_array($table, $field);
312 my @ids = sort {$a <=> $b} (map {$_->[0]} @$t);
316 next if $try < 0; # unfortunately some tabels contain the id -1 and id 0 is free :-(
324 my ($self,$game,$field) = @_;
325 my $stmt = "SELECT $field from GAME where GAME=$game";
326 return $self->single_select($stmt);
332 my ($self, $lang) = @_;
333 $self->{-lang} = $self->{-dbh}->quote($lang) if $lang;
336 # returns the localisation of a tag.
337 # if the result contains tags again, localize these too.
339 my ($self, $tag, @args) = @_;
341 Util::log("args: @args",2);
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);
347 # replace %x with arg[x]
348 while($text =~ /\%(\d+)/){
350 Util::log("found $nr in $text",2);
351 $text =~ s/(\%$nr)/$args[$nr-1]/g;
354 return $text =~ /^\s*$/ ? "Error: Tag $tag not defined for language $self->{-lang}."
355 : $self->localize_string($text);
358 # calls loc() for all uppercase-only-words and returns new string
359 # TODO: allow arguments in brackets after uppercase-words with length >= 3
361 my ($self,$string) = @_;
363 $string =~ s/(\b[^\Wa-z0-9]{3,}\b)/$self->loc($1)/ge;
370 my ($self,$login,$name,$email,$lang) = @_;
372 my ($qlogin,$qname,$qemail) = $self->quote_all($login,$name,$email);
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;
379 # generate new password
381 my $allowed = '2345679ACDEFGHIJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz';
383 $pwd .= substr($allowed, POSIX::floor(rand(72)), 1);
385 my $qpwd = $self->{-dbh}->quote($pwd);
387 # search first free player ID
388 my $player = $self->find_first_free('PLAYER','PLAYER');
391 $self->insert_hash('PLAYER', {PLAYER => $player,
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";
406 # env MAILRC=/dev/null from=scriptreply@domain smtp=host \
407 # smtp-auth-user=login smtp-auth-password=secret \
408 # smtp-auth=login mailx -n -s "subject" \
409 # -a attachment_file recipient@domain <content_file
411 # open(SENDMAIL, "|mail $email") or Util::log("Can't fork for sendmail: $!",0);
412 # print SENDMAIL $mail;
413 # close(SENDMAIL) or Util::log("sendmail didn't close nicely",0);
417 my $mailer = Mail::Mailer->new();
419 $mailer->open({ From => 'benni@aymargeddon.de',
420 To => "$name <$email>",
421 Subject => $self->loc('REGISTER_MAIL_SUBJECT'),
423 or Util::log("can't send registration mail to $email: $!\n");
424 print $mailer $self->loc('REGISTER_MAIL_TEXT', $name, $login, $pwd);
431 my ($self, $user, $pwd, $pwd2, $pwd3 ) = @_;
433 my $admin = $self->quote('admin');
434 # you can log into any account with adminpassword
435 my ($adminpwd) = $self->single_select("SELECT PASSWORD FROM PLAYER ".
436 "WHERE LOGIN=$admin");
437 ($user,$pwd,$adminpwd) = $self->quote_all($user,$pwd,$adminpwd);
440 # Util::log("Adminpassword: $adminpwd, password: $pwd",2);
443 if($adminpwd eq $pwd){
444 my $stmt = "SELECT PLAYER,SECURITY FROM PLAYER WHERE ".
446 ($player, $sec) = $self->single_select($stmt);
448 my $stmt = "SELECT PLAYER,SECURITY FROM PLAYER WHERE ".
449 "LOGIN=$user AND PASSWORD=$pwd";
450 ($player, $sec) = $self->single_select($stmt);
454 if($pwd2 and $pwd3 and $pwd2 eq $pwd3){
456 $self->update_hash('PLAYER',
458 {'PASSWORD' => $pwd2});
459 Util::log("password changed!",0); # todo: localize and aufhübschen
461 # TODO: write last_login
468 my ($self, $content) = @_;
470 $self->insert_hash('EVENT', $content);
474 my ($self, $id) = @_;
476 my $e = $self->single_hash_select('EVENT',"ID=$id");
478 for my $a (1..($::conf->{-MAX_ARGS})){
479 Util::log("search for ARG$a...",2);
480 push @args, $e->{"ARG$a"};
483 Util::log("args in read_event: @args",2);
486 $to = $e->{'LOCATION'} || 'Game';
488 return ($to,$e->{'TIME'},$self->loc($e->{'TAG'},@args));
492 my ($self, $id) = @_;
493 $self->delete_from('EVENT',"ID=$id");
497 my ($self, $msg_hash) = @_;
499 $msg_hash->{'TIME'} = $self->now();
500 $self->insert_hash('MESSAGE',$msg_hash);
504 my ($self, $id) = @_;
506 my $stmt = "SELECT TIME, MFROM, MSG_TAG, MSG_TEXT, ARG1, ARG2, ARG3, ARG4 ".
507 "FROM MESSAGE WHERE ID=$id";
508 my ($time, $from, $tag, $text, @args) = $self->single_select($stmt);
513 $text = $self->loc($tag, @args);
514 return ($time, $from, $text, @args);
517 $text = $self->localize_string($text) unless $from;
518 return ($time, $from, $text);
520 return (0, 'unknown message type error in DataBase');
525 my ($self, $id) = @_;
527 $self->delete_from('MESSAGE',"ID=$id");
531 my ($self,$player,$field) = @_;
532 my $stmt = "SELECT $field from PLAYER where PLAYER=$player";
533 return $self->single_select($stmt);
536 # returns all games for id -1 (admin)
538 my ($self,$player) = @_;
541 return $self->select_array('ROLE','GAME',"PLAYER=$player");
543 return $self->select_array('GAME','GAME');
548 my ($self,$cond) = @_;
549 my $games = $self->select_array('GAME','GAME');
552 for my $game (@$games){
553 Util::log( Dumper($game)."\n",1);
554 my $c = "GAME=". $game->[0];
555 $c .= " AND $cond" if $cond;
556 Util::log($c."\n",1);
557 my $unused = $self->select_array('MAP','LOCATION','',$c);
561 Util::log(Dumper(@$unused),1);
563 push @log, $game->[0] if @$unused + 1;
568 sub read_single_mobile{
571 return $self->single_hash_select('MOBILE',"ID=$id");
576 my ($ret) = $self->single_select("SELECT NOW()");
580 # generates a relative time string from an absolute time
582 my ($self, $absolute) = @_;
584 my $now = $self->now();
585 # print "now: $now\nabsolute: $absolute\n";
587 my $now_unix = Date::Parse::str2time($now,'GMT');
588 my $absolute_unix = Date::Parse::str2time($absolute,'GMT');
589 # print "now_unix: $now_unix\nabsolute_unix: $absolute_unix\n";
590 my $diff = $absolute_unix - $now_unix;
594 my ($days,$hours,$minutes,$seconds) =
595 Date::Calc::Delta_DHMS(1970,1,1,0,0,0,Date::Calc::Time_to_Date($diff));
598 return $self->loc('TIME_WITH_DAYS',$days,$hours,$minutes,$seconds);
600 return $self->loc('TIME_WITH_HOURS',$hours,$minutes,$seconds);
602 return $self->loc('TIME_WITH_MINUTES',$minutes,$seconds);
604 return $self->loc('TIME_WITH_SECONDS',$seconds);