1 #**************************************************************************
2 # Copyright (C) 2009 by Michael Andreen <harvATruinDOTnu> *
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. *
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. *
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 #**************************************************************************/
20 package NDIRC::Commands::Intel;
27 use MooseX::MethodAttributes;
30 : Help(Usage: .sethostile X:Y:Z)
33 my ($self,$c,$msg) = @_;
34 my ($x,$y,$z) = $msg =~ /^(\d+)\D(\d+)\D(\d+)$/ or die 'ARGS';
37 my $findid = $dbh->prepare(q{SELECT planetid(?,?,?,tick())});
38 my ($id) = $dbh->selectrow_array($findid,undef,$x,$y,$z);
40 my $rv = $dbh->do(q{UPDATE planets SET planet_status = 'Hostile' WHERE pid = $1}
43 $c->reply("$x:$y:$z is now marked s hostile");
44 $c->intel_log($id,"Set planet_status to: 'Hostile'");
50 : Help(Usage: .setnick X:Y:Z nick)
53 my ($self,$c,$msg) = @_;
54 my ($x,$y,$z,$nick) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS';
57 my $findid = $dbh->prepare(q{
58 SELECT nick, pid, alliance FROM planets WHERE pid = planetid(?,?,?,tick())
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.");
67 $dbh->do(q{UPDATE planets SET nick = $1 WHERE pid = $2}
68 ,undef,$nick,$planet->{pid});
70 $c->reply("$x:$y:$z nick has been changed from <b>$planet->{nick}</b> to <b>$nick</b>");
72 $c->reply("$x:$y:$z nick has been set to $nick");
74 $c->intel_log($planet->{pid},"Set nick to: $nick");
80 : Help(Usage: .setally X:Y:Z ally | % can be used for wildcards \%-crew\% will match [F-Crew])
83 my ($self,$c,$msg) = @_;
84 my ($x,$y,$z,$ally) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS';
88 if ($ally ne 'unknown'){
89 ($aid,$ally) = $dbh->selectrow_array(q{
90 SELECT aid,alliance FROM alliances WHERE alliance ILIKE ?
94 $c->reply("Don't set ND planets manually.");
96 my $findid = $dbh->prepare(q{
97 SELECT pid,alliance,aid FROM current_planet_stats WHERE x = ? AND y = ? and z = ?
99 my ($id,$alliance,$alliance_id) = $dbh->selectrow_array($findid,undef,$x,$y,$z);
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");
108 $dbh->do(q{UPDATE planets SET alliance = $1 WHERE pid = $2}
110 if (defined $alliance){
111 $c->reply("Changed $x:$y:$z from <b>$alliance</b> to <b>$ally</b>");
113 $c->reply("Setting $x:$y:$z as <b>$ally</b>");
115 $c->intel_log($id,"Set alliance_id to: $aid ($ally)");
119 $c->reply("Couldn't find such an alliance");
124 : Help(Usage: .setchannel X:Y:Z channel | Set channel or bot for a planet)
125 : ACL(irc_setchannel)
127 my ($self,$c,$msg) = @_;
128 my ($x,$y,$z,$channel) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS';
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");
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");
143 $c->reply("Changed $x:$y:$z from <b>$oc</b> to <b>$channel</b>");
145 $c->reply("Setting $x:$y:$z as <b>$channel</b>");
148 $c->reply("Couldn't find a planet at $x:$y:$z");
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 _)
157 my ($self,$c,$msg) = @_;
158 my ($tag) = $msg =~ /^(\w+)$/ or die 'ARGS';
161 my $query = $dbh->prepare(q{
162 INSERT INTO available_planet_tags (tag) VALUES($1)
165 $query->execute($tag);
167 if ($@ =~ /duplicate key value/){
168 $c->reply("<b>$tag</b> already exists");
173 $c->reply("Added tag <b>$tag</b>");
177 : Help(Usage: .addtag X:Y:Z tag | Adds the tag to planet X:Y:Z)
181 my ($self,$c,$msg) = @_;
182 my ($x,$y,$z,$tag) = $msg =~ /^(\d+)\D+(\d+)\D+(\d+)\s+(\S+)$/ or die 'ARGS';
185 my $query = $dbh->prepare(q{
186 INSERT INTO planet_tags (uid,pid,tag) VALUES($1,planetid($2,$3,$4,tick()),$5)
189 $query->execute($c->uid,$x,$y,$z,$tag);
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
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");
215 : Help(Usage: .deltag X:Y:Z tag | Removes the tag from planet X:Y:Z)
219 my ($self,$c,$msg) = @_;
220 my ($x,$y,$z,$tag) = $msg =~ /^(\d+)\D+(\d+)\D+(\d+)\s+(\S+)$/ or die 'ARGS';
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
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");
232 : Help(Usage: .allycoords ally | % can be used for wildcards \%-crew\% will match [F-Crew])
233 : ACL(irc_allycoords)
235 my ($self,$c,$msg) = @_;
236 my ($ally) = $msg =~ /^(\S+)$/ or die 'ARGS';
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
246 $c->reply("No alliance matching '$ally'");
249 my $query = $dbh->prepare(q{
250 SELECT coords(x,y,z) FROM current_planet_stats WHERE alliance = $1 ORDER BY x,y,z
254 while (my $p = $query->fetchrow_hashref){
255 push @planets,$p->{coords};
257 my $kmem = scalar @planets;
258 $c->reply("$a ($kmem/$members) : ". join " ", @planets);
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])
265 my ($self,$c,$msg) = @_;
266 my ($ally,$min) = $msg =~ /^(\S+)(?: (\d+))?$/ or die 'ARGS';
270 my ($a) = $dbh->selectrow_array(q{
272 FROM alliances JOIN alliance_stats USING (aid)
273 WHERE tick = (SELECT max(tick) FROM alliance_stats)
274 AND alliance ILIKE $1
277 $c->reply("No alliance matching '$ally'");
280 my $query = $dbh->prepare(q{
281 SELECT x,y, count(*) FROM current_planet_stats WHERE alliance = $1
283 HAVING count(*) >= $2
284 ORDER BY count DESC,x,y
286 $query->execute($a,$min);
288 while (my $g = $query->fetchrow_hashref){
289 push @gals,"$g->{x}:$g->{y} ($g->{count})";
291 my $kgals = scalar @gals;
292 $c->reply("$a ($kgals) : ". join " ", @gals);