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