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