From 8fa0654350fcf47b257f2ffa7256b3c4c6152475 Mon Sep 17 00:00:00 2001 From: Michael Andreen Date: Sat, 5 Dec 2009 21:57:00 +0100 Subject: [PATCH] Converted Intel --- Commands/Intel.pm | 435 +++++++++++++++++++++++----------------------- 1 file changed, 221 insertions(+), 214 deletions(-) diff --git a/Commands/Intel.pm b/Commands/Intel.pm index 2b39d4b..e039386 100644 --- a/Commands/Intel.pm +++ b/Commands/Intel.pm @@ -17,279 +17,286 @@ # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * #**************************************************************************/ -package NDIRC::Commands::Intel; - use strict; use warnings; use feature ':5.10'; -use Moose; -use MooseX::MethodAttributes; +use MooseX::Declare; +use NDIRC::Dispatcher; -sub sethostile - : Help(Usage: .sethostile X:Y:Z) - : ACL(irc_sethostile) -{ - my ($self,$c,$msg) = @_; - my ($x,$y,$z) = $msg =~ /^(\d+)\D(\d+)\D(\d+)$/ or die 'ARGS'; - my $dbh = $c->model; +command sethostile => { + help => q(Usage: .sethostile X:Y:Z), + acl => q(irc_sethostile), +}, class extends NDIRC::Command { + method execute($c,$msg) { + my ($x,$y,$z) = $msg =~ /^(\d+)\D(\d+)\D(\d+)$/ or die 'ARGS'; + my $dbh = $c->model; - my $findid = $dbh->prepare(q{SELECT planetid(?,?,?,tick())}); - my ($id) = $dbh->selectrow_array($findid,undef,$x,$y,$z); - $dbh->begin_work; - my $rv = $dbh->do(q{UPDATE planets SET planet_status = 'Hostile' WHERE pid = $1} - ,undef,$id); - if ($rv == 1){ - $c->reply("$x:$y:$z is now marked s hostile"); - $c->intel_log($id,"Set planet_status to: 'Hostile'"); + my $findid = $dbh->prepare(q{SELECT planetid(?,?,?,tick())}); + my ($id) = $dbh->selectrow_array($findid,undef,$x,$y,$z); + $dbh->begin_work; + my $rv = $dbh->do(q{UPDATE planets SET planet_status = 'Hostile' WHERE pid = $1} + ,undef,$id); + if ($rv == 1){ + $c->reply("$x:$y:$z is now marked s hostile"); + $c->intel_log($id,"Set planet_status to: 'Hostile'"); + } + $dbh->commit; } - $dbh->commit; -} +}; -sub setnick - : Help(Usage: .setnick X:Y:Z nick) - : ACL(irc_setnick) -{ - my ($self,$c,$msg) = @_; - my ($x,$y,$z,$nick) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS'; - my $dbh = $c->model; +command setnick => { + help => q(Usage: .setnick X:Y:Z nick), + acl => q(irc_setnick), +}, class extends NDIRC::Command { + method execute($c,$msg) { + my ($x,$y,$z,$nick) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS'; + my $dbh = $c->model; - my $findid = $dbh->prepare(q{ + my $findid = $dbh->prepare(q{ SELECT nick, pid, alliance FROM planets WHERE pid = planetid(?,?,?,tick()) - }); - my $planet = $dbh->selectrow_hashref($findid,undef,$x,$y,$z); - unless($planet->{pid}){ - $c->reply("Couldn't find any planet with coords $x:$y:$z"); - }elsif($planet->{alliance} ~~ 'NewDawn'){ - $c->reply("This is an ND planet."); - }else{ - $dbh->begin_work; - $dbh->do(q{UPDATE planets SET nick = $1 WHERE pid = $2} - ,undef,$nick,$planet->{pid}); - if ($planet->{nick}){ - $c->reply("$x:$y:$z nick has been changed from $planet->{nick} to $nick"); + }); + my $planet = $dbh->selectrow_hashref($findid,undef,$x,$y,$z); + unless($planet->{pid}){ + $c->reply("Couldn't find any planet with coords $x:$y:$z"); + }elsif($planet->{alliance} ~~ 'NewDawn'){ + $c->reply("This is an ND planet."); }else{ - $c->reply("$x:$y:$z nick has been set to $nick"); + $dbh->begin_work; + $dbh->do(q{UPDATE planets SET nick = $1 WHERE pid = $2} + ,undef,$nick,$planet->{pid}); + if ($planet->{nick}){ + $c->reply("$x:$y:$z nick has been changed from $planet->{nick} to $nick"); + }else{ + $c->reply("$x:$y:$z nick has been set to $nick"); + } + $c->intel_log($planet->{pid},"Set nick to: $nick"); + $dbh->commit; } - $c->intel_log($planet->{pid},"Set nick to: $nick"); - $dbh->commit; } -} +}; -sub setally - : Help(Usage: .setally X:Y:Z ally | % can be used for wildcards \%-crew\% will match [F-Crew]) - : ACL(irc_setally) -{ - my ($self,$c,$msg) = @_; - my ($x,$y,$z,$ally) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS'; - my $dbh = $c->model; +command setally => { + help => q(Usage: .setally X:Y:Z ally | % can be used for wildcards \%-crew\% will match [F-Crew]), + acl => q(irc_setally), +}, class extends NDIRC::Command { + method execute($c,$msg) { + my ($x,$y,$z,$ally) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS'; + my $dbh = $c->model; - my $aid; - if ($ally ne 'unknown'){ - ($aid,$ally) = $dbh->selectrow_array(q{ + my $aid; + if ($ally ne 'unknown'){ + ($aid,$ally) = $dbh->selectrow_array(q{ SELECT aid,alliance FROM alliances WHERE alliance ILIKE ? - },undef,$ally); - } - if ($aid ~~ 1){ - $c->reply("Don't set ND planets manually."); - }elsif ($ally){ - my $findid = $dbh->prepare(q{ + },undef,$ally); + } + if ($aid ~~ 1){ + $c->reply("Don't set ND planets manually."); + }elsif ($ally){ + my $findid = $dbh->prepare(q{ SELECT pid,alliance,aid FROM current_planet_stats WHERE x = ? AND y = ? and z = ? - }); - my ($id,$alliance,$alliance_id) = $dbh->selectrow_array($findid,undef,$x,$y,$z); - unless ($id){ - $c->reply("Couldn't find a planet at $x:$y:$z"); - }elsif ($alliance_id ~~ 1){ - $c->reply("$x:$y:$z is an ND planet."); - }elsif ($alliance_id ~~ $aid){ - $c->reply("$x:$y:$z is already set to $ally"); - }else{ - $dbh->begin_work; - $dbh->do(q{UPDATE planets SET alliance = $1 WHERE pid = $2} - ,undef,$ally,$id); - if (defined $alliance){ - $c->reply("Changed $x:$y:$z from $alliance to $ally"); + }); + my ($id,$alliance,$alliance_id) = $dbh->selectrow_array($findid,undef,$x,$y,$z); + unless ($id){ + $c->reply("Couldn't find a planet at $x:$y:$z"); + }elsif ($alliance_id ~~ 1){ + $c->reply("$x:$y:$z is an ND planet."); + }elsif ($alliance_id ~~ $aid){ + $c->reply("$x:$y:$z is already set to $ally"); }else{ - $c->reply("Setting $x:$y:$z as $ally"); + $dbh->begin_work; + $dbh->do(q{UPDATE planets SET alliance = NULLIF($1,'unknown') WHERE pid = $2} + ,undef,$ally,$id); + if (defined $alliance){ + $c->reply("Changed $x:$y:$z from $alliance to $ally"); + }else{ + $c->reply("Setting $x:$y:$z as $ally"); + } + $c->intel_log($id,"Set alliance_id to: $aid ($ally)"); + $dbh->commit; } - $c->intel_log($id,"Set alliance_id to: $aid ($ally)"); - $dbh->commit; + }else{ + $c->reply("Couldn't find such an alliance"); } - }else{ - $c->reply("Couldn't find such an alliance"); } -} +}; -sub setchannel - : Help(Usage: .setchannel X:Y:Z channel | Set channel or bot for a planet) - : ACL(irc_setchannel) -{ - my ($self,$c,$msg) = @_; - my ($x,$y,$z,$channel) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS'; - my $dbh = $c->model; +command setchannel => { + help => q(Usage: .setchannel X:Y:Z channel | Set channel or bot for a planet), + acl => q(irc_setchannel), +}, class extends NDIRC::Command { + method execute($c,$msg) { + my ($x,$y,$z,$channel) = $msg =~ /^(\d+)\D(\d+)\D(\d+) (\S+)$/ or die 'ARGS'; + my $dbh = $c->model; - my $findid = $dbh->prepare_cached(q{SELECT pid,channel FROM current_planet_stats - WHERE x = ? AND y = ? and z = ?}); - my ($id,$oc) = $dbh->selectrow_array($findid,undef,$x,$y,$z); - if ($channel ~~ $oc){ - $c->reply("$x:$y:$z already got $oc as channel"); - }elsif($id){ - $dbh->begin_work; - $dbh->do(q{UPDATE planets SET channel = $1 WHERE pid = $2} - ,undef,$channel,$id); - $c->intel_log($id,"Set channel to: $channel"); - $dbh->commit; - if ($oc){ - $c->reply("Changed $x:$y:$z from $oc to $channel"); + my $findid = $dbh->prepare_cached(q{SELECT pid,channel FROM current_planet_stats + WHERE x = ? AND y = ? and z = ?}); + my ($id,$oc) = $dbh->selectrow_array($findid,undef,$x,$y,$z); + if ($channel ~~ $oc){ + $c->reply("$x:$y:$z already got $oc as channel"); + }elsif($id){ + $dbh->begin_work; + $dbh->do(q{UPDATE planets SET channel = $1 WHERE pid = $2} + ,undef,$channel,$id); + $c->intel_log($id,"Set channel to: $channel"); + $dbh->commit; + if ($oc){ + $c->reply("Changed $x:$y:$z from $oc to $channel"); + }else{ + $c->reply("Setting $x:$y:$z as $channel"); + } }else{ - $c->reply("Setting $x:$y:$z as $channel"); + $c->reply("Couldn't find a planet at $x:$y:$z"); } - }else{ - $c->reply("Couldn't find a planet at $x:$y:$z"); } -} +}; -sub newtag - : 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 _) - : ACL(irc_newtag) - : Type(member) -{ - my ($self,$c,$msg) = @_; - my ($tag) = $msg =~ /^(\w+)$/ or die 'ARGS'; +command newtag => { + 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 _), + acl => q(irc_newtag), + type => q(member), +}, class extends NDIRC::Command { + method execute($c,$msg) { + my ($tag) = $msg =~ /^(\w+)$/ or die 'ARGS'; - my $dbh = $c->model; - my $query = $dbh->prepare(q{ + my $dbh = $c->model; + my $query = $dbh->prepare(q{ INSERT INTO available_planet_tags (tag) VALUES($1) - }); - eval { - $query->execute($tag); - }; - if ($@ =~ /duplicate key value/){ - $c->reply("$tag already exists"); - return; - }elsif ($@){ - die $@; + }); + eval { + $query->execute($tag); + }; + if ($@ =~ /duplicate key value/){ + $c->reply("$tag already exists"); + return; + }elsif ($@){ + die $@; + } + $c->reply("Added tag $tag"); } - $c->reply("Added tag $tag"); -} +}; -sub addtag - : Help(Usage: .addtag X:Y:Z tag | Adds the tag to planet X:Y:Z) - : ACL(irc_addtag) - : Type(member) -{ - my ($self,$c,$msg) = @_; - my ($x,$y,$z,$tag) = $msg =~ /^(\d+)\D+(\d+)\D+(\d+)\s+(\S+)$/ or die 'ARGS'; - my $dbh = $c->model; +command addtag => { + help => q(Usage: .addtag X:Y:Z tag | Adds the tag to planet X:Y:Z), + acl => q(irc_addtag), + type => q(member), +}, class extends NDIRC::Command { + method execute($c,$msg) { + my ($x,$y,$z,$tag) = $msg =~ /^(\d+)\D+(\d+)\D+(\d+)\s+(\S+)$/ or die 'ARGS'; + my $dbh = $c->model; - my $query = $dbh->prepare(q{ + my $query = $dbh->prepare(q{ INSERT INTO planet_tags (uid,pid,tag) VALUES($1,planetid($2,$3,$4,tick()),$5) - }); - eval { - $query->execute($c->uid,$x,$y,$z,$tag); - }; - given ($@){ - when(''){ - $c->reply("Added tag $tag to $x:$y:$z"); - }when (/duplicate key value/){ - $c->reply("$x:$y:$z already has tag $tag"); - }when (/null value in column "pid"/){ - $c->reply("No planet with coords $x:$y:$z"); - }when ($@ =~ /foreign key constraint "planet_tags_tag_fkey"/){ - $query = $dbh->prepare(q{ + }); + eval { + $query->execute($c->uid,$x,$y,$z,$tag); + }; + given ($@){ + when(''){ + $c->reply("Added tag $tag to $x:$y:$z"); + }when (/duplicate key value/){ + $c->reply("$x:$y:$z already has tag $tag"); + }when (/null value in column "pid"/){ + $c->reply("No planet with coords $x:$y:$z"); + }when ($@ =~ /foreign key constraint "planet_tags_tag_fkey"/){ + $query = $dbh->prepare(q{ SELECT array_to_string(array_agg(tag),' ') FROM (SELECT tag FROM available_planet_tags WHERE tag % $1 ORDER BY similarity(tag,$1) DESC) t - }); - my ($tags) = $dbh->selectrow_array($query,undef,$tag); - $c->reply("$tag is not a valid tag. Either you need to add it with .newtag," - ." or you want one of: $tags"); - } - default { - die $@; + }); + my ($tags) = $dbh->selectrow_array($query,undef,$tag); + $c->reply("$tag is not a valid tag. Either you need to add it with .newtag," + ." or you want one of: $tags"); + } + default { + die $@; + } } } -} +}; -sub deltag - : Help(Usage: .deltag X:Y:Z tag | Removes the tag from planet X:Y:Z) - : ACL(irc_addtag) - : Type(member) -{ - my ($self,$c,$msg) = @_; - my ($x,$y,$z,$tag) = $msg =~ /^(\d+)\D+(\d+)\D+(\d+)\s+(\S+)$/ or die 'ARGS'; - my $dbh = $c->model; +command deltag => { + help => q(Usage: .deltag X:Y:Z tag | Removes the tag from planet X:Y:Z), + acl => q(irc_addtag), + type => q(member), +}, class extends NDIRC::Command { + method execute($c,$msg) { + my ($x,$y,$z,$tag) = $msg =~ /^(\d+)\D+(\d+)\D+(\d+)\s+(\S+)$/ or die 'ARGS'; + my $dbh = $c->model; - my $query = $dbh->prepare(q{ + my $query = $dbh->prepare(q{ DELETE FROM planet_tags WHERE uid = $1 AND pid = planetid($2,$3,$4,tick()) AND tag LIKE $5 - }); - $query->execute($c->uid,$x,$y,$z,$tag); - my $rows = $query->rows; - $c->reply("Removed $rows matching $tag from $x:$y:$z"); -} + }); + $query->execute($c->uid,$x,$y,$z,$tag); + my $rows = $query->rows; + $c->reply("Removed $rows matching $tag from $x:$y:$z"); + } +}; -sub allycoords - : Help(Usage: .allycoords ally | % can be used for wildcards \%-crew\% will match [F-Crew]) - : ACL(irc_allycoords) -{ - my ($self,$c,$msg) = @_; - my ($ally) = $msg =~ /^(\S+)$/ or die 'ARGS'; - my $dbh = $c->model; +command allycoords => { + help => q(Usage: .allycoords ally | % can be used for wildcards \%-crew\% will match [F-Crew]), + acl => q(irc_allycoords), +}, class extends NDIRC::Command { + method execute($c,$msg) { + my ($ally) = $msg =~ /^(\S+)$/ or die 'ARGS'; + my $dbh = $c->model; - my ($a, $members) = $dbh->selectrow_array(q{ + my ($a, $members) = $dbh->selectrow_array(q{ SELECT alliance, members FROM alliances JOIN alliance_stats USING (aid) WHERE tick = (SELECT max(tick) FROM alliance_stats) AND alliance ILIKE $1 - },undef,$ally); - unless ($a){ - $c->reply("No alliance matching '$ally'"); - return; - } - my $query = $dbh->prepare(q{ + },undef,$ally); + unless ($a){ + $c->reply("No alliance matching '$ally'"); + return; + } + my $query = $dbh->prepare(q{ SELECT coords(x,y,z) FROM current_planet_stats WHERE alliance = $1 ORDER BY x,y,z - }); - $query->execute($a); - my @planets; - while (my $p = $query->fetchrow_hashref){ - push @planets,$p->{coords}; + }); + $query->execute($a); + my @planets; + while (my $p = $query->fetchrow_hashref){ + push @planets,$p->{coords}; + } + my $kmem = scalar @planets; + $c->reply("$a ($kmem/$members) : ". join " ", @planets); } - my $kmem = scalar @planets; - $c->reply("$a ($kmem/$members) : ". join " ", @planets); -} +}; -sub allygals - : 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]) - : ACL(irc_allygals) -{ - my ($self,$c,$msg) = @_; - my ($ally,$min) = $msg =~ /^(\S+)(?: (\d+))?$/ or die 'ARGS'; - my $dbh = $c->model; - $min //= 3; +command allygals => { + 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]), + acl => q(irc_allygals), +}, class extends NDIRC::Command { + method execute($c,$msg) { + my ($ally,$min) = $msg =~ /^(\S+)(?: (\d+))?$/ or die 'ARGS'; + my $dbh = $c->model; + $min //= 3; - my ($a) = $dbh->selectrow_array(q{ + my ($a) = $dbh->selectrow_array(q{ SELECT alliance FROM alliances JOIN alliance_stats USING (aid) WHERE tick = (SELECT max(tick) FROM alliance_stats) AND alliance ILIKE $1 - },undef,$ally); - unless ($a){ - $c->reply("No alliance matching '$ally'"); - return; - } - my $query = $dbh->prepare(q{ + },undef,$ally); + unless ($a){ + $c->reply("No alliance matching '$ally'"); + return; + } + my $query = $dbh->prepare(q{ SELECT x,y, count(*) FROM current_planet_stats WHERE alliance = $1 GROUP BY x,y HAVING count(*) >= $2 ORDER BY count DESC,x,y - }); - $query->execute($a,$min); - my @gals; - while (my $g = $query->fetchrow_hashref){ - push @gals,"$g->{x}:$g->{y} ($g->{count})"; + }); + $query->execute($a,$min); + my @gals; + while (my $g = $query->fetchrow_hashref){ + push @gals,"$g->{x}:$g->{y} ($g->{count})"; + } + my $kgals = scalar @gals; + $c->reply("$a ($kgals) : ". join " ", @gals); } - my $kgals = scalar @gals; - $c->reply("$a ($kgals) : ". join " ", @gals); -} +}; 1; -- 2.39.2