X-Git-Url: https://ruin.nu/git/?a=blobdiff_plain;f=Commands%2FIntel.pm;h=2b39d4be38e6cd0aac1768633841b5fee46d9ba5;hb=13fea23cf96258707f674e67ec7b2512f0727c40;hp=e529018a6ea6d29bbf1a10438ecbbdbc71ef8e25;hpb=3545424da594911c238f7ad0d5381159b8970a38;p=NDIRC.git diff --git a/Commands/Intel.pm b/Commands/Intel.pm index e529018..2b39d4b 100644 --- a/Commands/Intel.pm +++ b/Commands/Intel.pm @@ -37,7 +37,7 @@ sub sethostile 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 id = $1} + 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"); @@ -55,25 +55,241 @@ sub setnick my $dbh = $c->model; my $findid = $dbh->prepare(q{ -SELECT nick, id, alliance_id FROM planets WHERE id = planetid(?,?,?,tick()) +SELECT nick, pid, alliance FROM planets WHERE pid = planetid(?,?,?,tick()) }); my $planet = $dbh->selectrow_hashref($findid,undef,$x,$y,$z); - unless($planet->{id}){ + unless($planet->{pid}){ $c->reply("Couldn't find any planet with coords $x:$y:$z"); - }elsif($planet->{alliance_id} ~~ 1){ + }elsif($planet->{alliance} ~~ 'NewDawn'){ $c->reply("This is an ND planet."); }else{ $dbh->begin_work; - $dbh->do(q{UPDATE planets SET nick = $1 WHERE id = $2} - ,undef,$nick,$planet->{id}); + $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->{id},"Set nick to: $nick"); + $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; + + 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{ +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"); + }else{ + $c->reply("Setting $x:$y:$z as $ally"); + } + $c->intel_log($id,"Set alliance_id to: $aid ($ally)"); + $dbh->commit; + } + }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; + + 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("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'; + + 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 $@; + } + $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; + + 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{ +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 $@; + } + } +} + +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; + + 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"); +} + +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; + + 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{ +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}; + } + 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; + + 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{ +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})"; + } + my $kgals = scalar @gals; + $c->reply("$a ($kgals) : ". join " ", @gals); +} + 1;