Commands/Intel.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::Intel;
  21
  22 use strict;
  23 use warnings;
  24 use feature ':5.10';
  25
  26 use Moose;
  27 use MooseX::MethodAttributes;
  28
  29 sub sethostile
  30         : Help(Usage: .sethostile X:Y:Z)
  31         : ACL(irc_sethostile)
  32 {
  33         my ($self,$c,$msg) = @_;
  34         my ($x,$y,$z) = $msg =~ /^(\d+)\D(\d+)\D(\d+)$/ or die 'ARGS';
  35         my $dbh = $c->model;
  36
  37         my $findid = $dbh->prepare(q{SELECT planetid(?,?,?,tick())});
  38         my ($id) = $dbh->selectrow_array($findid,undef,$x,$y,$z);
  39         $dbh->begin_work;
  40         my $rv = $dbh->do(q{UPDATE planets SET planet_status = 'Hostile' WHERE pid = $1}
  41                 ,undef,$id);
  42         if ($rv == 1){
  43                 $c->reply("$x:$y:$z is now marked s hostile");
  44                 $c->intel_log($id,"Set planet_status to: 'Hostile'");
  45         }
  46         $dbh->commit;
  47 }
  48
  49 sub setnick
  50         : Help(Usage: .setnick X:Y:Z nick)
  51         : ACL(irc_setnick)
  52 {
  53         my ($self,$c,$msg) = @_;
  54         my ($x,$y,$z,$nick) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS';
  55         my $dbh = $c->model;
  56
  57         my $findid = $dbh->prepare(q{
  58 SELECT nick, pid, alliance FROM planets WHERE pid = planetid(?,?,?,tick())
  59                 });
  60         my $planet = $dbh->selectrow_hashref($findid,undef,$x,$y,$z);
  61         unless($planet->{pid}){
  62                 $c->reply("Couldn't find any planet with coords $x:$y:$z");
  63         }elsif($planet->{alliance} ~~ 'NewDawn'){
  64                 $c->reply("This is an ND planet.");
  65         }else{
  66                 $dbh->begin_work;
  67                 $dbh->do(q{UPDATE planets SET nick = $1 WHERE pid = $2}
  68                         ,undef,$nick,$planet->{pid});
  69                 if ($planet->{nick}){
  70                         $c->reply("$x:$y:$z nick has been changed from <b>$planet->{nick}</b> to <b>$nick</b>");
  71                 }else{
  72                         $c->reply("$x:$y:$z nick has been set to $nick");
  73                 }
  74                 $c->intel_log($planet->{pid},"Set nick to: $nick");
  75                 $dbh->commit;
  76         }
  77 }
  78
  79 sub setally
  80         : Help(Usage: .setally X:Y:Z ally | % can be used for wildcards \%-crew\% will match [F-Crew])
  81         : ACL(irc_setally)
  82 {
  83         my ($self,$c,$msg) = @_;
  84         my ($x,$y,$z,$ally) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS';
  85         my $dbh = $c->model;
  86
  87         my $aid;
  88         if ($ally ne 'unknown'){
  89                 ($aid,$ally) = $dbh->selectrow_array(q{
  90 SELECT aid,alliance FROM alliances WHERE alliance ILIKE ?
  91                 },undef,$ally);
  92         }
  93         if ($aid ~~ 1){
  94                 $c->reply("Don't set ND planets manually.");
  95         }elsif ($ally){
  96                 my $findid = $dbh->prepare(q{
  97 SELECT pid,alliance,aid FROM current_planet_stats WHERE x = ? AND y = ? and z = ?
  98                 });
  99                 my ($id,$alliance,$alliance_id) = $dbh->selectrow_array($findid,undef,$x,$y,$z);
 100                 unless ($id){
 101                         $c->reply("Couldn't find a planet at $x:$y:$z");
 102                 }elsif ($alliance_id ~~ 1){
 103                         $c->reply("$x:$y:$z is an ND planet.");
 104                 }elsif ($alliance_id ~~ $aid){
 105                         $c->reply("$x:$y:$z is already set to $ally");
 106                 }else{
 107                         $dbh->begin_work;
 108                         $dbh->do(q{UPDATE planets SET alliance = $1 WHERE pid = $2}
 109                                 ,undef,$ally,$id);
 110                         if (defined $alliance){
 111                                 $c->reply("Changed $x:$y:$z from <b>$alliance</b> to <b>$ally</b>");
 112                         }else{
 113                                 $c->reply("Setting $x:$y:$z as <b>$ally</b>");
 114                         }
 115                         $c->intel_log($id,"Set alliance_id to: $aid ($ally)");
 116                         $dbh->commit;
 117                 }
 118         }else{
 119                 $c->reply("Couldn't find such an alliance");
 120         }
 121 }
 122
 123 sub setchannel
 124         : Help(Usage: .setchannel X:Y:Z channel | Set channel or bot for a planet)
 125         : ACL(irc_setchannel)
 126 {
 127         my ($self,$c,$msg) = @_;
 128         my ($x,$y,$z,$channel) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS';
 129         my $dbh = $c->model;
 130
 131         my $findid = $dbh->prepare_cached(q{SELECT pid,channel FROM current_planet_stats
 132                 WHERE x = ? AND y = ? and z = ?});
 133         my ($id,$oc) = $dbh->selectrow_array($findid,undef,$x,$y,$z);
 134         if ($channel ~~ $oc){
 135                 $c->reply("$x:$y:$z already got $oc as channel");
 136         }elsif($id){
 137                 $dbh->begin_work;
 138                 $dbh->do(q{UPDATE planets SET channel = $1 WHERE pid = $2}
 139                         ,undef,$channel,$id);
 140                 $c->intel_log($id,"Set channel to: $channel");
 141                 $dbh->commit;
 142                 if ($oc){
 143                         $c->reply("Changed $x:$y:$z from <b>$oc</b> to <b>$channel</b>");
 144                 }else{
 145                         $c->reply("Setting $x:$y:$z as <b>$channel</b>");
 146                 }
 147         }else{
 148                 $c->reply("Couldn't find a planet at $x:$y:$z");
 149         }
 150 }
 151
 152 sub newtag
 153         : Help(Usage: .newtag tag | Creates a new tag that can be used with addtag, tags can only contain a-z, A-Z, 0-9 and _)
 154         : ACL(irc_newtag)
 155         : Type(member)
 156 {
 157         my ($self,$c,$msg) = @_;
 158         my ($tag) = $msg =~ /^(\w+)$/ or die 'ARGS';
 159
 160         my $dbh = $c->model;
 161         my $query = $dbh->prepare(q{
 162 INSERT INTO available_planet_tags (tag) VALUES($1)
 163                 });
 164         eval {
 165                 $query->execute($tag);
 166         };
 167         if ($@ =~ /duplicate key value/){
 168                 $c->reply("<b>$tag</b> already exists");
 169                 return;
 170         }elsif ($@){
 171                 die $@;
 172         }
 173         $c->reply("Added tag <b>$tag</b>");
 174 }
 175
 176 sub addtag
 177         : Help(Usage: .addtag X:Y:Z tag | Adds the tag to planet X:Y:Z)
 178         : ACL(irc_addtag)
 179         : Type(member)
 180 {
 181         my ($self,$c,$msg) = @_;
 182         my ($x,$y,$z,$tag) = $msg =~ /^(\d+)\D+(\d+)\D+(\d+)\s+(\S+)$/ or die 'ARGS';
 183         my $dbh = $c->model;
 184
 185         my $query = $dbh->prepare(q{
 186 INSERT INTO planet_tags (uid,pid,tag) VALUES($1,planetid($2,$3,$4,tick()),$5)
 187                 });
 188         eval {
 189                 $query->execute($c->uid,$x,$y,$z,$tag);
 190         };
 191         given ($@){
 192                 when(''){
 193                         $c->reply("Added tag <b>$tag</b> to $x:$y:$z");
 194                 }when (/duplicate key value/){
 195                         $c->reply("$x:$y:$z already has tag <b>$tag</b>");
 196                 }when (/null value in column "pid"/){
 197                         $c->reply("No planet with coords $x:$y:$z");
 198                 }when ($@ =~ /foreign key constraint "planet_tags_tag_fkey"/){
 199                         $query = $dbh->prepare(q{
 200 SELECT array_to_string(array_agg(tag),' ')
 201 FROM (SELECT tag FROM available_planet_tags
 202         WHERE tag % $1 ORDER BY similarity(tag,$1) DESC) t
 203                         });
 204                         my ($tags) = $dbh->selectrow_array($query,undef,$tag);
 205                         $c->reply("<b>$tag</b> is not a valid tag. Either you need to add it with .newtag,"
 206                                 ." or you want one of: $tags");
 207                 }
 208                 default {
 209                         die $@;
 210                 }
 211         }
 212 }
 213
 214 sub deltag
 215         : Help(Usage: .deltag X:Y:Z tag | Removes the tag from planet X:Y:Z)
 216         : ACL(irc_addtag)
 217         : Type(member)
 218 {
 219         my ($self,$c,$msg) = @_;
 220         my ($x,$y,$z,$tag) = $msg =~ /^(\d+)\D+(\d+)\D+(\d+)\s+(\S+)$/ or die 'ARGS';
 221         my $dbh = $c->model;
 222
 223         my $query = $dbh->prepare(q{
 224 DELETE FROM planet_tags WHERE uid = $1 AND pid = planetid($2,$3,$4,tick()) AND tag LIKE $5
 225                 });
 226         $query->execute($c->uid,$x,$y,$z,$tag);
 227         my $rows = $query->rows;
 228         $c->reply("Removed <b>$rows</b> matching $tag from $x:$y:$z");
 229 }
 230
 231 sub allycoords
 232         : Help(Usage: .allycoords ally | % can be used for wildcards \%-crew\% will match [F-Crew])
 233         : ACL(irc_allycoords)
 234 {
 235         my ($self,$c,$msg) = @_;
 236         my ($ally) = $msg =~ /^(\S+)$/ or die 'ARGS';
 237         my $dbh = $c->model;
 238
 239         my ($a, $members) = $dbh->selectrow_array(q{
 240 SELECT alliance, members
 241 FROM alliances JOIN alliance_stats USING (aid)
 242 WHERE tick = (SELECT max(tick) FROM alliance_stats)
 243         AND alliance ILIKE $1
 244                 },undef,$ally);
 245         unless ($a){
 246                 $c->reply("No alliance matching '$ally'");
 247                 return;
 248         }
 249         my $query = $dbh->prepare(q{
 250 SELECT coords(x,y,z) FROM current_planet_stats WHERE alliance = $1 ORDER BY x,y,z
 251                 });
 252         $query->execute($a);
 253         my @planets;
 254         while (my $p = $query->fetchrow_hashref){
 255                 push @planets,$p->{coords};
 256         }
 257         my $kmem = scalar @planets;
 258         $c->reply("$a ($kmem/$members) : ". join " ", @planets);
 259 }
 260
 261 sub allygals
 262         : Help(Usage: .allygals ally [min] | lists gals with a minimum of 3, or specified, allied planets. % can be used for wildcards \%-crew\% will match [F-Crew])
 263         : ACL(irc_allygals)
 264 {
 265         my ($self,$c,$msg) = @_;
 266         my ($ally,$min) = $msg =~ /^(\S+)(?: (\d+))?$/ or die 'ARGS';
 267         my $dbh = $c->model;
 268         $min //= 3;
 269
 270         my ($a) = $dbh->selectrow_array(q{
 271 SELECT alliance
 272 FROM alliances JOIN alliance_stats USING (aid)
 273 WHERE tick = (SELECT max(tick) FROM alliance_stats)
 274         AND alliance ILIKE $1
 275                 },undef,$ally);
 276         unless ($a){
 277                 $c->reply("No alliance matching '$ally'");
 278                 return;
 279         }
 280         my $query = $dbh->prepare(q{
 281 SELECT x,y, count(*) FROM current_planet_stats WHERE alliance = $1
 282 GROUP BY x,y
 283 HAVING count(*) >= $2
 284 ORDER BY count DESC,x,y
 285                 });
 286         $query->execute($a,$min);
 287         my @gals;
 288         while (my $g = $query->fetchrow_hashref){
 289                 push @gals,"$g->{x}:$g->{y} ($g->{count})";
 290         }
 291         my $kgals = scalar @gals;
 292         $c->reply("$a ($kgals) : ". join " ", @gals);
 293 }
 294
 295 1;