scripts/ndreport.pl

   1 #!/usr/bin/perl
   2 q{
   3 /***************************************************************************
   4  *   Copyright (C) 2006 by Michael Andreen <harvATruinDOTnu>               *
   5  *                                                                         *
   6  *   This program is free software; you can redistribute it and/or modify  *
   7  *   it under the terms of the GNU General Public License as published by  *
   8  *   the Free Software Foundation; either version 2 of the License, or     *
   9  *   (at your option) any later version.                                   *
  10  *                                                                         *
  11  *   This program is distributed in the hope that it will be useful,       *
  12  *   but WITHOUT ANY WARRANTY; without even the implied warranty of        *
  13  *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *
  14  *   GNU General Public License for more details.                          *
  15  *                                                                         *
  16  *   You should have received a copy of the GNU General Public License     *
  17  *   along with this program; if not, write to the                         *
  18  *   Free Software Foundation, Inc.,                                       *
  19  *   51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.         *
  20  ***************************************************************************/
  21 };
  22
  23 use strict;
  24 use warnings;
  25 use local::lib;
  26 use DBI;
  27 use DBD::Pg qw(:pg_types);
  28 use CGI qw/:standard/;
  29 use Data::Dumper;
  30
  31 use Email::Simple;
  32 use Encode;
  33 use MIME::QuotedPrint;
  34
  35 use FindBin;
  36 use lib "$FindBin::Bin/../lib";
  37 use ND::DB;
  38
  39 my $dbh = ND::DB::DB();
  40
  41 my @text = <>;
  42 my $text = join '',@text;
  43
  44 $text =~ /ndreport\+(.+?)\@ruin\.nu/;
  45
  46 my $user = $1;
  47
  48 my $email = Email::Simple->new($text);
  49
  50 my $body =  decode('ISO-8859-1', $email->body);
  51
  52 my $c = $dbh->prepare(q{
  53 SELECT coords(x,y,z), uid
  54 FROM users u
  55         LEFT JOIN current_planet_stats p USING (pid)
  56 WHERE username = $1
  57         AND uid IN (SELECT uid FROM groupmembers WHERE gid = 'M')
  58 });
  59 my ($coords, $uid) = $dbh->selectrow_array($c, undef, $user);
  60
  61 $coords //= '(no coords entered)';
  62
  63 my $attacker = $dbh->prepare(q{
  64 SELECT pid, race FROM current_planet_stats WHERE x = $1 AND y = $2 AND z = $3
  65 });
  66
  67 my $report = $dbh->prepare(q{INSERT INTO irc_requests (channel,uid,message) VALUES('def',$1,$2)});
  68
  69 unless ($body =~ /Report of events in tick (\d+)/) {
  70         exit 0;
  71 }
  72
  73 my $tick = $1;
  74
  75 my $message = "Tick <b>$tick</b>: *$user* <b>$coords</b> has incs\n";
  76
  77 my $add_inc = $dbh->prepare(q{INSERT INTO incomings (call,pid,eta,amount,fleet) VALUES($1,$2,$3,$4,$5)});
  78
  79 my $find_call = $dbh->prepare(q{
  80 SELECT call, count(*) AS count
  81 FROM calls
  82         JOIN incomings i USING (call)
  83 WHERE uid = $1 AND landing_tick = $2
  84 GROUP BY call
  85 });
  86 my $add_call = $dbh->prepare(q{
  87 INSERT INTO calls
  88         (uid,landing_tick,info)
  89         VALUES($1,$2,'')
  90 RETURNING call
  91 });
  92
  93
  94 my %incs;
  95 while($body =~ /jumpgate from (.+?), located at (\d+):(\d+):(\d+).+?our system in tick (\d+) and appears to have (\d+)/sg){
  96         my ($fleet, $x,$y,$z,$landing_tick, $amount) = ($1,$2,$3,$4,$5,$6);
  97
  98         my $eta = $landing_tick - $tick;
  99
 100         my ($pid, $race) = $dbh->selectrow_array($attacker,undef, $x,$y,$z);
 101
 102         push @{$incs{$landing_tick}}, {x => $x, y => $y, z => $z, eta => $eta, amount => $amount, race => $race, fleet => $fleet, pid => $pid};
 103 }
 104
 105 for my $landing_tick (sort keys %incs) {
 106         $message .= "\n> Landing tick: *$landing_tick*";
 107         my $call;
 108         if ($uid) {
 109                 if (my $c = $dbh->selectrow_hashref($find_call, undef, $uid, $landing_tick)) {
 110                         $call = $c->{call};
 111                         $message .= "\n__Previously an addtional **$c->{count}** fleets landing on this tick__"
 112                 }
 113                 else
 114                 {
 115                         ($call) = $dbh->selectrow_array($add_call, undef, $uid, $landing_tick);
 116                 }
 117         }
 118         $message .= "\n```";
 119         for my $i (@{$incs{$landing_tick}}) {
 120                 if ($uid)
 121                 {
 122                         $add_inc->execute($call, $i->{pid}, $i->{eta}, $i->{amount}, $i->{fleet});
 123                 }
 124                 $message .= "\n$i->{x}:$i->{y}:$i->{z} $i->{race} $i->{eta} $i->{amount} $i->{fleet} "
 125         }
 126         $message .= "```";
 127 }
 128
 129
 130 #print $message;
 131
 132 $report->execute(-5,$message);
 133
 134 $dbh->disconnect;
 135
 136 system 'killall','-USR1', 'ndbot.pl';