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 unless ($body =~ /Report of events in tick (\d+)/) {
  53         exit 0;
  54 }
  55
  56 my $tick = $1;
  57
  58 my $c = $dbh->prepare(q{
  59 SELECT coords(x,y,z), uid, pid
  60 FROM users u
  61         LEFT JOIN current_planet_stats p USING (pid)
  62 WHERE username = $1
  63         AND uid IN (SELECT uid FROM groupmembers WHERE gid = 'M')
  64 });
  65 my ($coords, $uid, $pid) = $dbh->selectrow_array($c, undef, $user);
  66
  67 $coords //= '(no coords entered)';
  68
  69 my $attacker = $dbh->prepare(q{
  70 SELECT pid, race FROM current_planet_stats WHERE x = $1 AND y = $2 AND z = $3
  71 });
  72
  73 my $report = $dbh->prepare(q{INSERT INTO irc_requests (channel,uid,message) VALUES('def',$1,$2)});
  74
  75
  76 my $message = "Tick **$tick**: *$user* $coords has incs\n";
  77
  78 my $add_inc = $dbh->prepare(q{INSERT INTO incomings (call,pid,eta,amount,fleet) VALUES($1,$2,$3,$4,$5)});
  79
  80 my $find_call = $dbh->prepare(q{
  81 SELECT call, count(*) AS count
  82 FROM calls
  83         JOIN incomings i USING (call)
  84 WHERE uid = $1 AND landing_tick = $2
  85 GROUP BY call
  86 });
  87 my $add_call = $dbh->prepare(q{
  88 INSERT INTO calls
  89         (uid,landing_tick,info)
  90         VALUES($1,$2,'')
  91 RETURNING call
  92 });
  93
  94 my $fleetcatch = $dbh->prepare(q{
  95 SELECT count(*) FROM launch_confirmations WHERE uid = $1 AND back = $2
  96 });
  97
  98
  99 my %incs;
 100 while($body =~ /jumpgate from (.+?), located at (\d+):(\d+):(\d+).+?our system in tick (\d+) and appears to have (\d+)/sg){
 101         my ($fleet, $x,$y,$z,$landing_tick, $amount) = ($1,$2,$3,$4,$5,$6);
 102
 103         my $eta = $landing_tick - $tick;
 104
 105         my ($pid, $race) = $dbh->selectrow_array($attacker,undef, $x,$y,$z);
 106
 107         push @{$incs{$landing_tick}}, {x => $x, y => $y, z => $z, eta => $eta, amount => $amount, race => $race, fleet => $fleet, pid => $pid};
 108 }
 109
 110 for my $landing_tick (sort keys %incs) {
 111         $message .= "\n> Landing tick: *$landing_tick*";
 112         my $call;
 113         if ($uid) {
 114                 my ($returning) = $dbh->selectrow_array($fleetcatch, undef, $uid, $landing_tick);
 115                 if ($returning > 0) {
 116                         $message .= "\n**THIS IS A POSSIBLE FLEETCATCH!**"
 117                 }
 118                 if (my $c = $dbh->selectrow_hashref($find_call, undef, $uid, $landing_tick)) {
 119                         $call = $c->{call};
 120                         $message .= "\n__Previously an addtional **$c->{count}** fleets landing on this tick__"
 121                 }
 122                 else
 123                 {
 124                         ($call) = $dbh->selectrow_array($add_call, undef, $uid, $landing_tick);
 125                 }
 126         }
 127         $message .= "\n```";
 128         for my $i (@{$incs{$landing_tick}}) {
 129                 if ($uid)
 130                 {
 131                         $add_inc->execute($call, $i->{pid}, $i->{eta}, $i->{amount}, $i->{fleet});
 132                 }
 133                 $message .= "\n$i->{x}:$i->{y}:$i->{z} $i->{race} $i->{eta} $i->{amount} $i->{fleet} "
 134         }
 135         $message .= "```";
 136 }
 137
 138
 139 #print $message;
 140
 141 $report->execute(-5,$message);
 142
 143 $dbh->disconnect;
 144
 145 system 'killall','-USR1', 'ndbot.pl';