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("msg $target", "<b>$mess</b>");
  41         $c->message("msg ".$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         ,concat(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                 chop($call->{shiptype});
  72                 $callinfo = "(Anti $call->{shiptype} ETA: $call->{eta})";
  73                 if($call->{status} eq 'Covered'){
  74                         $c->reply("Call <b>$callnr</b> $callinfo is covered.");
  75                         return;
  76                 }
  77         }
  78         $c->message("notice $ND::memchan", "DEFENSE REQUIRED!! WAKE UP!!");
  79         $c->message("msg $ND::memchan", "DEFENSE REQUIRED $mess $callinfo MSG "
  80                 .$c->nick." TO RESPOND");
  81 }
  82
  83 sub settype
  84         : Help(Usage: .settype incId type | or: .settyp callId X:Y:Z type | or: .settypeall callId type)
  85         : Type(def)
  86         : ACL(irc_settype)
  87         : Alias(settypeall)
  88 {
  89         my ($self,$c,$msg) = @_;
  90         my $dbh = $c->model;
  91
  92         my $query = q{
  93 SELECT inc,call,shiptype, coords(x,y,z),c.landing_tick - tick() AS eta
  94 FROM incomings i
  95         JOIN current_planet_stats p USING (pid)
  96         JOIN calls c USING (call)
  97         };
  98         my $fleets;
  99         my $type;
 100         my $call;
 101
 102         if ($self->name eq 'settypeall'){
 103                 ($call,$type) = $msg =~ /^(\d+) (.*)$/ or die 'ARGS';
 104
 105                 $fleets = $dbh->prepare($query . q{
 106 WHERE call = ?
 107                 });
 108                 $fleets->execute($call);
 109         }else{
 110                 my ($id,$x,$y,$z,$t) = $msg =~ /^(\d+) (\d+):(\d+):(\d+) (.*)$/;
 111                 if (defined $id){
 112                         $fleets = $dbh->prepare($query . q{
 113 WHERE call = ? AND pid = planetid(?,?,?,tick())
 114                         });
 115                         $fleets->execute($id,$x,$y,$z);
 116                 }else{
 117                         ($id,$t) = $msg =~ /^(\d+) (.*)$/ or die 'ARGS';
 118                         $fleets = $dbh->prepare($query . q{
 119 WHERE inc = ?
 120                         });
 121                         $fleets->execute($id);
 122                 }
 123                 $type = $t;
 124         }
 125
 126         $type = CGI::escapeHTML($type);
 127         $dbh->begin_work;
 128         my $deflog = '';
 129         my $settype = $dbh->prepare(q{UPDATE incomings SET shiptype = ? WHERE inc = ?});
 130         while (my $inc = $fleets->fetchrow_hashref){
 131                 $call //= $inc->{call};
 132                 if ($inc->{eta} < 0){
 133                         $c->reply("This call is old. Did you use the call id instead of inc id by"
 134                                 ." accident? You can use .settypeall callid to set the type on all incs"
 135                                 ." in a call. Or use webbie if you really want to update this old call.");
 136                         $dbh->rollback;
 137                         return;
 138                 }
 139                 $settype->execute($type,$inc->{inc});
 140                 $deflog .= "Set fleet: [B]$inc->{inc} [/B] to: [B]$type [/B]\n";
 141                 $c->reply("Set fleet $inc->{inc} from $inc->{coords} on call $call to $type (previously $inc->{shiptype})");
 142         }
 143         if ($fleets->rows == 0){
 144                 $c->reply("No matching fleets");
 145                 $dbh->rollback;
 146         }else{
 147                 $c->def_log($call,$deflog);
 148                 $dbh->commit;
 149         }
 150 }
 151
 152 sub calltake
 153         : Help(Usage: .calltake callid | sets the dc. also markes as covered/ignored with .callcov and .callignore)
 154         : Type(def)
 155         : ACL(irc_calltake)
 156         : Alias(qw/callcov callignore/)
 157 {
 158         my ($self,$c,$msg) = @_;
 159         my ($id) = $msg =~ /^(\d+)$/ or die 'ARGS';
 160         my $dbh = $c->model;
 161
 162         my $status = 'Open';
 163
 164         given ($self->{name}){
 165                 when('callignore'){
 166                         $status = 'Ignored';
 167                 }
 168                 when('callcov'){
 169                         $status = 'Covered';
 170                 }
 171         }
 172
 173         $dbh->begin_work;
 174         my $rows = $dbh->do(q{
 175 UPDATE calls SET dc = (SELECT uid FROM users WHERE hostmask ILIKE $1)
 176         ,status = $3
 177 WHERE call = $2
 178                 },undef,$c->host,$id,$status);
 179         if ($rows == 1){
 180                 $c->reply("Setting status on call $id to $status");
 181                 $c->def_log($id , "Changed status: [B]$status [/B]");
 182                 $dbh->commit;
 183         }else{
 184                 $c->reply("$id is not a valid call");
 185                 $dbh->rollback;
 186         }
 187 }
 188
 189 sub setcalc
 190         : Help(Usage: .setcalc callId calc | sets the calc for the given call.)
 191         : Type(def)
 192         : ACL(irc_setcalc)
 193 {
 194         my ($self,$c,$msg) = @_;
 195         my ($id,$calc) = $msg =~ /^(\d+) (.+)$/ or die 'ARGS';
 196         my $dbh = $c->model;
 197
 198         $dbh->begin_work;
 199         my $rows = $dbh->do(q{UPDATE calls SET calc = $2 WHERE id = $1}
 200                 ,undef,$id, $calc);
 201         if ($rows == 1){
 202                 $c->reply("Updated calc call <b>$id</b>");
 203                 $calc = CGI::escapeHTML($calc);
 204                 $c->def_log($id , 'Updated calc to: [URL]'.$calc.'[/URL]');
 205                 $dbh->commit;
 206         }else{
 207                 $c->reply("$id is not a valid call");
 208                 $dbh->rollback;
 209         }
 210 }
 211
 212 sub getcalc
 213         : Help(Usage: .getcalc callId | receives the calc for the given call)
 214         : Type(def)
 215         : ACL(irc_getcalc)
 216 {
 217         my ($self,$c,$msg) = @_;
 218         my ($id) = $msg =~ /^(\d+)$/ or die 'ARGS';
 219         my $dbh = $c->model;
 220
 221         my $calc = $dbh->selectrow_array(q{
 222 SELECT calc FROM calls WHERE id = $1}
 223                 ,undef,$id);
 224         $calc //= "Bad call id, there is no such call.";
 225         $c->reply("Calc for call <b>$id</b>: $calc");
 226 }
 227
 228
 229 1;
 230