Commands/Def.pm

   1 #**************************************************************************
   2 #   Copyright (C) 2009 by Michael Andreen <harvATruinDOTnu>               *
   3 #                                                                         *
   4 #   This program is free software; you can redistribute it and/or modify  *
   5 #   it under the terms of the GNU General Public License as published by  *
   6 #   the Free Software Foundation; either version 2 of the License, or     *
   7 #   (at your option) any later version.                                   *
   8 #                                                                         *
   9 #   This program is distributed in the hope that it will be useful,       *
  10 #   but WITHOUT ANY WARRANTY; without even the implied warranty of        *
  11 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *
  12 #   GNU General Public License for more details.                          *
  13 #                                                                         *
  14 #   You should have received a copy of the GNU General Public License     *
  15 #   along with this program; if not, write to the                         *
  16 #   Free Software Foundation, Inc.,                                       *
  17 #   51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.         *
  18 #**************************************************************************/
  19
  20 package NDIRC::Commands::Def;
  21
  22 use strict;
  23 use warnings;
  24 use feature ':5.10';
  25
  26 use CGI;
  27
  28 use Moose;
  29 use MooseX::MethodAttributes;
  30
  31 sub anon
  32         : Help(syntax: .anon nick message)
  33         : Type(def)
  34         : ACL(irc_anondef)
  35 {
  36         my ($self,$c,$msg) = @_;
  37
  38         my ($target,$mess) = $msg =~ /^(\S+) (.*)$/ or die 'ARGS';
  39
  40         $c->message(privmsg => $target, "<b>$mess</b>");
  41         $c->message(privmsg => $c->channel, "<c03>$target << $mess</c>");
  42 }
  43
  44 sub defcall
  45         : Help(syntax: .defcall [callid] | if a call id is given, then shiptypes and eta will be fetched from the database and added to the message)
  46         : Type(def)
  47         : ACL(irc_defcall)
  48 {
  49         my ($self,$c,$msg) = @_;
  50         my ($callnr,$mess) = $msg =~ /^(\d+)?(.*)$/ or die 'ARGS';
  51         my $dbh = $c->model;
  52
  53         my $callinfo = "";
  54         if ($callnr){
  55                 my $st = $dbh->prepare(q{
  56 SELECT status
  57         ,c.landing_tick - (SELECT value::integer FROM misc WHERE id = 'TICK') AS eta
  58         ,array_to_string(array_agg(i.shiptype),'/') AS shiptype
  59 FROM calls c
  60         JOIN incomings i USING (call)
  61         LEFT OUTER JOIN users dc ON dc.uid = c.dc
  62 WHERE c.call = ?
  63 GROUP BY c.call,c.landing_tick,c.status
  64 ORDER BY c.landing_tick;
  65                 });
  66                 my $call = $dbh->selectrow_hashref($st,undef,$callnr);
  67                 unless (defined $call->{status}){
  68                         $c->reply("No call with id: $callnr");
  69                         return;
  70                 }
  71                 $callinfo = "(Anti $call->{shiptype} ETA: $call->{eta})";
  72                 if($call->{status} eq 'Covered'){
  73                         $c->reply("Call <b>$callnr</b> $callinfo is covered.");
  74                         return;
  75                 }
  76         }
  77         $c->message(notice => $ND::memchan, "DEFENSE REQUIRED!! WAKE UP!!");
  78         $c->message(privmsg => $ND::memchan, "DEFENSE REQUIRED $mess $callinfo MSG "
  79                 .$c->nick." TO RESPOND");
  80 }
  81
  82 sub settype
  83         : Help(Usage: .settype incId type | or: .settyp callId X:Y:Z type | or: .settypeall callId type)
  84         : Type(def)
  85         : ACL(irc_settype)
  86         : Alias(settypeall)
  87 {
  88         my ($self,$c,$msg) = @_;
  89         my $dbh = $c->model;
  90
  91         my $query = q{
  92 SELECT inc,call,shiptype, coords(x,y,z),c.landing_tick - tick() AS eta
  93 FROM incomings i
  94         JOIN current_planet_stats p USING (pid)
  95         JOIN calls c USING (call)
  96         };
  97         my $fleets;
  98         my $type;
  99         my $call;
 100
 101         if ($self->name eq 'settypeall'){
 102                 ($call,$type) = $msg =~ /^(\d+) (.*)$/ or die 'ARGS';
 103
 104                 $fleets = $dbh->prepare($query . q{
 105 WHERE call = ?
 106                 });
 107                 $fleets->execute($call);
 108         }else{
 109                 my ($id,$x,$y,$z,$t) = $msg =~ /^(\d+) (\d+):(\d+):(\d+) (.*)$/;
 110                 if (defined $id){
 111                         $fleets = $dbh->prepare($query . q{
 112 WHERE call = ? AND pid = planetid(?,?,?,tick())
 113                         });
 114                         $fleets->execute($id,$x,$y,$z);
 115                 }else{
 116                         ($id,$t) = $msg =~ /^(\d+) (.*)$/ or die 'ARGS';
 117                         $fleets = $dbh->prepare($query . q{
 118 WHERE inc = ?
 119                         });
 120                         $fleets->execute($id);
 121                 }
 122                 $type = $t;
 123         }
 124
 125         $type = CGI::escapeHTML($type);
 126         $dbh->begin_work;
 127         my $deflog = '';
 128         my $settype = $dbh->prepare(q{UPDATE incomings SET shiptype = ? WHERE inc = ?});
 129         while (my $inc = $fleets->fetchrow_hashref){
 130                 $call //= $inc->{call};
 131                 if ($inc->{eta} < 0){
 132                         $c->reply("This call is old. Did you use the call id instead of inc id by"
 133                                 ." accident? You can use .settypeall callid to set the type on all incs"
 134                                 ." in a call. Or use webbie if you really want to update this old call.");
 135                         $dbh->rollback;
 136                         return;
 137                 }
 138                 $settype->execute($type,$inc->{inc});
 139                 $deflog .= "Set fleet: [B]$inc->{inc} [/B] to: [B]$type [/B]\n";
 140                 $c->reply("Set fleet $inc->{inc} from $inc->{coords} on call $call to $type (previously $inc->{shiptype})");
 141         }
 142         if ($fleets->rows == 0){
 143                 $c->reply("No matching fleets");
 144                 $dbh->rollback;
 145         }else{
 146                 $c->def_log($call,$deflog);
 147                 $dbh->commit;
 148         }
 149 }
 150
 151 sub calltake
 152         : Help(Usage: .calltake callid | sets the dc. also markes as covered/ignored with .callcov and .callignore)
 153         : Type(def)
 154         : ACL(irc_calltake)
 155         : Alias(qw/callcov callignore/)
 156 {
 157         my ($self,$c,$msg) = @_;
 158         my ($id) = $msg =~ /^(\d+)$/ or die 'ARGS';
 159         my $dbh = $c->model;
 160
 161         my $status = 'Open';
 162
 163         given ($self->{name}){
 164                 when('callignore'){
 165                         $status = 'Ignored';
 166                 }
 167                 when('callcov'){
 168                         $status = 'Covered';
 169                 }
 170         }
 171
 172         $dbh->begin_work;
 173         my $rows = $dbh->do(q{
 174 UPDATE calls SET dc = (SELECT uid FROM users WHERE hostmask ILIKE $1)
 175         ,status = $3
 176 WHERE call = $2
 177                 },undef,$c->host,$id,$status);
 178         if ($rows == 1){
 179                 $c->reply("Setting status on call $id to $status");
 180                 $c->def_log($id , "Changed status: [B]$status [/B]");
 181                 $dbh->commit;
 182         }else{
 183                 $c->reply("$id is not a valid call");
 184                 $dbh->rollback;
 185         }
 186 }
 187
 188 sub setcalc
 189         : Help(Usage: .setcalc callId calc | sets the calc for the given call.)
 190         : Type(def)
 191         : ACL(irc_setcalc)
 192 {
 193         my ($self,$c,$msg) = @_;
 194         my ($id,$calc) = $msg =~ /^(\d+) (.+)$/ or die 'ARGS';
 195         my $dbh = $c->model;
 196
 197         $dbh->begin_work;
 198         my $rows = $dbh->do(q{UPDATE calls SET calc = $2 WHERE id = $1}
 199                 ,undef,$id, $calc);
 200         if ($rows == 1){
 201                 $c->reply("Updated calc call <b>$id</b>");
 202                 $calc = CGI::escapeHTML($calc);
 203                 $c->def_log($id , 'Updated calc to: [URL]'.$calc.'[/URL]');
 204                 $dbh->commit;
 205         }else{
 206                 $c->reply("$id is not a valid call");
 207                 $dbh->rollback;
 208         }
 209 }
 210
 211 sub getcalc
 212         : Help(Usage: .getcalc callId | receives the calc for the given call)
 213         : Type(def)
 214         : ACL(irc_getcalc)
 215 {
 216         my ($self,$c,$msg) = @_;
 217         my ($id) = $msg =~ /^(\d+)$/ or die 'ARGS';
 218         my $dbh = $c->model;
 219
 220         my $calc = $dbh->selectrow_array(q{
 221 SELECT calc FROM calls WHERE id = $1}
 222                 ,undef,$id);
 223         $calc //= "Bad call id, there is no such call.";
 224         $c->reply("Calc for call <b>$id</b>: $calc");
 225 }
 226
 227
 228 1;
 229