File Coverage

blib/lib/Circle/Net/IRC/Channel.pm

Criterion	Covered	Total	%
statement	65	473	13.7
branch	0	72	0.0
condition	0	22	0.0
subroutine	22	79	27.8
pod	0	44	0.0
total	87	690	12.6

#  You may distribute under the terms of the GNU General Public License
#
#  (C) Paul Evans, 2008-2017 -- [e-mail]

package Circle::Net::IRC::Channel;

use strict;
use warnings;
use 5.010; # //
use base qw( Circle::Net::IRC::Target );

our $VERSION = '0.173320';

use Carp;

use Circle::TaggedString;

use Circle::Widget::Box;
use Circle::Widget::Entry;
use Circle::Widget::Label;

use POSIX qw( strftime );

sub init_prop_occupant_summary
{
   return { total => 0 };
}

sub on_connected
{
   my $self = shift;
   $self->SUPER::on_connected;

   if( $self->{autojoin} ) {
      $self->join( on_joined => sub { } );
   }
}

sub join
{
   my $self = shift;
   my %args = @_;

   my $on_joined = $args{on_joined};
   ref $on_joined eq "CODE" or croak "Expected 'on_joined' as CODE ref";

   my $key = $args{key} // $self->{key};

   my $net = $self->{net};
   $net->do_join( $self->get_prop_name, $key );

   $self->{on_joined} = $on_joined;
   $self->{on_join_error} = $args{on_join_error};
}

sub invite
{
   my $self = shift;
   my ( $nick ) = @_;

   my $irc = $self->{irc};
   # INVITE user #channel
   $irc->send_message( "INVITE", undef, $nick, $self->get_prop_name );
}

sub kick
{
   my $self = shift;
   my ( $nick, $message ) = @_;

   my $irc = $self->{irc};
   $irc->send_message( "KICK", undef, $self->get_prop_name, $nick, $message );
}

sub mode
{
   my $self = shift;
   my ( $modestr, @args ) = @_;

   my $irc = $self->{irc};
   $irc->send_message( "MODE", undef, $self->get_prop_name, $modestr, @args );
}

sub method_mode
{
   my $self = shift; my $ctx = shift;
   my ( $modestr, $argsarray ) = @_;
   $self->mode( $modestr, @$argsarray );
}

sub part
{
   my $self = shift;
   my %args = @_;

   my $on_parted = $args{on_parted};
   ref $on_parted eq "CODE" or croak "Expected 'on_parted' as CODE ref";

   my $irc = $self->{irc};
   $irc->send_message( "PART", undef, $self->get_prop_name, defined $args{message} ? $args{message} : ( "" ) );

   $self->{on_parted} = $on_parted;
}

sub topic
{
   my $self = shift;
   my ( $topic ) = @_;

   my $irc = $self->{irc};
   $irc->send_message( "TOPIC", undef, $self->get_prop_name, $topic );
}

sub method_topic
{
   my $self = shift; my $ctx = shift;
   $self->topic( @_ );
}

sub user_leave
{
   my $self = shift;
   my ( $nick_folded ) = @_;

   $self->del_prop_occupants( $nick_folded );
   $self->post_update_occupants;
}

sub gen_modestr
{
   my $self = shift;

   # This is a dynamic property

   my $mode = $self->get_prop_mode;

   # Order the mode as the server declares

   my $irc = $self->{irc};
   my $channelmodes = $irc->server_info( "channelmodes" );

   my @modes = sort { index( $channelmodes, $a ) <=> index( $channelmodes, $b ) } keys %$mode;

   my $str = "+";
   my @args;

   foreach my $modechar ( @modes ) {
      $str .= $modechar;
      push @args, $mode->{$modechar} if length $mode->{$modechar};
   }

   return CORE::join( " ", $str, @args );
}

sub apply_modes
{
   my $self = shift;
   my ( $modes ) = @_;

   my @mode_added;
   my @mode_deleted;

   my $irc = $self->{irc};
   my $PREFIX_FLAGS = $irc->isupport( "prefix_flags" );

   foreach my $m ( @$modes ) {
      my ( $type, $sense, $mode ) = @{$m}{qw( type sense mode )};

      my $pm = $sense > 0 ? "+" :
               $sense < 0 ? "-" :
                            "";

      if( !defined $type ) {
         print STDERR "TODO: Undefined type for chanmode $mode\n";
      }
      elsif( $type eq 'list' ) {
         print STDERR "TODO: A list chanmode $pm$mode $m->{value}\n";
      }
      elsif( $type eq 'occupant' ) {
         my $flag = $m->{flag};
         my $nick_folded = $m->{nick_folded};

         my $occupant = $self->get_prop_occupants->{$nick_folded};

         if( $sense > 0 ) {
            my $flags = $occupant->{flag} . $flag;
            # Now sort by PREFIX_FLAGS order
            $flags = CORE::join( "", sort { index( $PREFIX_FLAGS, $a ) <=> index( $PREFIX_FLAGS, $b ) } split( m//, $flags ) );
            $occupant->{flag} = $flags;
         }
         else {
            $occupant->{flag} =~ s/\Q$flag//g;
         }

         # We're not adding it, we're changing it
         $self->add_prop_occupants( $nick_folded => $occupant );
         $self->post_update_occupants;
      }
      elsif( $type eq 'value' ) {
         if( $sense > 0 ) {
            push @mode_added, [ $mode, $m->{value} ];
         }
         else {
            push @mode_deleted, $mode;
         }
      }
      elsif( $type eq 'bool' ) {
         if( $sense > 0 ) {
            push @mode_added, [ $mode, "" ];
         }
         else {
            push @mode_deleted, $mode;
         }
      }
   }

   if( @mode_added ) {
      # TODO: Allow CHANGE_ADD messages to add multiple key/value pairs
      foreach my $m ( @mode_added ) {
         $self->add_prop_mode( $m->[0] => $m->[1] );
      }
   }

   if( @mode_deleted ) {
      $self->del_prop_mode( $_ ) for @mode_deleted;
   }

   if( @mode_added or @mode_deleted or !defined $self->get_prop_modestr ) {
      $self->set_prop_modestr( $self->gen_modestr );
   }
}

sub post_update_occupants
{
   my $self = shift;

   my $irc = $self->{irc};

   my %count = map { $_ => 0 } "total", "", split( m//, $irc->isupport( "prefix_flags" ) );

   my $myflag;

   foreach my $occ ( values %{ $self->get_prop_occupants } ) {
      unless( defined $occ->{nick} ) {
         warn "Have an undefined nick in $occ in $self\n";
         next;
      }
      unless( defined $occ->{flag} ) {
         warn "Have an undefined flag for nick $occ->{nick} in $occ in $self\n";
         next;
      }

      my $flag = $occ->{flag} =~ m/^(.)/ ? $1 : "";

      $count{total}++;
      $count{$flag}++;

      $myflag = $flag if $irc->is_nick_me( $occ->{nick} );
   }

   $self->set_prop_occupant_summary( \%count );

   # Efficient application of property change
   my $old_myflag = $self->get_prop_my_flag;

   $self->set_prop_my_flag( $myflag ) if !defined $old_myflag or $old_myflag ne $myflag;
}

sub on_message_JOIN
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   my $nick = $hints->{prefix_nick};

   my $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}";

   if( $hints->{prefix_is_me} ) {
      $self->{on_joined}->( $self );

      $self->fire_event( "self_joined" );
      $self->push_displayevent( "irc.join", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost } );
      $self->bump_level( 1 );

      # Request the initial mode
      my $irc = $self->{irc};
      $irc->send_message( "MODE", undef, $self->get_prop_name );
   }
   else {
      $self->fire_event( "join", $nick );
      $self->push_displayevent( "irc.join", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost } );
      $self->bump_level( 1 );

      my $nick_folded = $hints->{prefix_nick_folded};
      my $newocc = { nick => $nick, flag => "" };

      $self->add_prop_occupants( $nick_folded => $newocc );
      $self->post_update_occupants;
   }

   return 1;
}

sub on_message_KICK
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   my $kicker  = $hints->{kicker_nick};
   my $kicked  = $hints->{kicked_nick};
   my $kickmsg = $hints->{text};

   defined $kickmsg or $kickmsg = "";

   my $net = $self->{net};
   my $kickmsg_formatted = $net->format_text( $kickmsg );

   my $irc = $self->{irc};
   if( $irc->is_nick_me( $kicked ) ) {
      $self->fire_event( "self_parted" );
      $self->push_displayevent( "irc.kick", { channel => $self->get_prop_name, kicker => $kicker, kicked => $kicked, kickmsg => $kickmsg_formatted } );
      $self->bump_level( 1 );
   }
   else {
      $self->fire_event( "kick", $kicker, $kicked, $kickmsg );
      $self->push_displayevent( "irc.kick", { channel => $self->get_prop_name, kicker => $kicker, kicked => $kicked, kickmsg => $kickmsg_formatted } );
      $self->bump_level( 1 );

      $self->user_leave( $hints->{kicked_nick_folded} );
   }

   return 1;
}

sub on_message_MODE
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   my $modes = $hints->{modes};

   my $nick;
   my $userhost;

   if( defined $hints->{prefix_nick} ) {
      $nick     = $hints->{prefix_nick};
      $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}";
   }
   else {
      $nick = $userhost = $hints->{prefix_host};
   }

   $self->apply_modes( $hints->{modes} );

   my $modestr = CORE::join( " ", $hints->{modechars}, @{ $hints->{modeargs} } );

   # 'nick' for legacy purposes, 'moder' for new
   $self->push_displayevent( "irc.mode", {
      channel  => $self->get_prop_name,
      nick     => $nick, moder => $nick,
      userhost => $userhost,
      mode     => $modestr,
   } );
   $self->bump_level( 1 );

   return 1;
}

sub on_message_NICK
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   my $oldnick_folded = $hints->{old_nick_folded};

   return 0 unless my $occ = $self->get_prop_occupants->{$oldnick_folded};

   my $oldnick = $hints->{old_nick};
   my $newnick = $hints->{new_nick};

   $self->push_displayevent( "irc.nick", { channel => $self->get_prop_name, oldnick => $oldnick, newnick => $newnick } );
   $self->bump_level( 1 );

   my $newnick_folded = $hints->{new_nick_folded};

   $self->del_prop_occupants( $oldnick_folded );

   $occ->{nick} = $newnick;
   $self->add_prop_occupants( $newnick_folded => $occ );

   $self->post_update_occupants;

   return 1;
}

sub on_message_PART
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   my $nick    = $hints->{prefix_nick};
   my $partmsg = $hints->{text};

   defined $partmsg or $partmsg = "";

   my $net = $self->{net};
   my $partmsg_formatted = $net->format_text( $partmsg );

   my $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}";

   if( $hints->{prefix_is_me} ) {
      $self->fire_event( "self_parted" );
      $self->push_displayevent( "irc.part", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost, partmsg => $partmsg_formatted } );
      $self->bump_level( 1 );

      $self->{on_parted}->( $self );
   }
   else {
      $self->fire_event( "part", $nick, $partmsg );
      $self->push_displayevent( "irc.part", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost, partmsg => $partmsg_formatted } );
      $self->bump_level( 1 );

      $self->user_leave( $hints->{prefix_nick_folded} );
   }

   return 1;
}

sub on_message_QUIT
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   my $nick_folded = $hints->{prefix_nick_folded};

   return 0 unless $self->get_prop_occupants->{$nick_folded};

   my $nick    = $hints->{prefix_nick};
   my $quitmsg = $hints->{text};

   defined $quitmsg or $quitmsg = "";

   my $net = $self->{net};
   my $quitmsg_formatted = $net->format_text( $quitmsg );

   my $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}";

   $self->push_displayevent( "irc.quit", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost, quitmsg => $quitmsg_formatted } );
   $self->bump_level( 1 );

   $self->user_leave( $nick_folded );

   return 1;
}

sub on_message_TOPIC
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   my $topic = $hints->{text};

   $self->set_prop_topic( $topic );

   my $nick = $hints->{prefix_name};

   my $userhost = "$hints->{prefix_user}\@$hints->{prefix_host}";

   $self->fire_event( "topic", $nick, $topic );
   $self->push_displayevent( "irc.topic", { channel => $self->get_prop_name, nick => $nick, userhost => $userhost, topic => $topic } );
   $self->bump_level( 1 );

   return 1;
}

sub on_message_RPL_CHANNELMODEIS
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   $self->apply_modes( $hints->{modes} );

   my $modestr = CORE::join( " ", $hints->{modechars}, @{ $hints->{modeargs} } );

   $self->push_displayevent( "irc.mode_is", { channel => $self->get_prop_name, mode => $modestr } );
   $self->bump_level( 1 );

   return 1;
}

sub on_message_RPL_NOTOPIC
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   $self->set_prop_topic( "" );

   return 1;
}

sub on_message_RPL_TOPIC
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   my $topic = $hints->{text};

   $self->set_prop_topic( $topic );

   $self->fire_event( "topic", undef, $topic );
   $self->push_displayevent( "irc.topic_is", { channel => $self->get_prop_name, topic => $topic } );
   $self->bump_level( 1 );

   return 1;
}

sub on_message_RPL_TOPICWHOTIME
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   my $timestr = strftime "%Y/%m/%d %H:%M:%S", localtime $hints->{timestamp};

   $self->push_displayevent( "irc.topic_by", { channel => $self->get_prop_name, topic_by => $hints->{topic_nick}, timestamp => $timestr } );
   $self->bump_level( 1 );

   return 1;
}

sub on_message_RPL_CHANNEL_URL
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   $self->push_displayevent( "irc.text", { server => $hints->{prefix_host}, text => "URL: $hints->{text}" } );
   $self->bump_level( 1 );

   return 1;
}

sub on_message_RPL_CHANNELCREATED
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   my $timestr = strftime "%Y/%m/%d %H:%M:%S", localtime $hints->{timestamp};

   $self->push_displayevent( "irc.text", { server => $hints->{prefix_host}, text => "Channel created $timestr" } );
   $self->bump_level( 1 );

   return 1;
}

sub on_message_names
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   $self->set_prop_occupants( $hints->{names} );
   $self->post_update_occupants;

   return 1;
}

sub command_part
   : Command_description("Part the channel")
   : Command_arg('message?', eatall => 1)
{
   my $self = shift;
   my ( $message, $cinv ) = @_;

   $self->part(
      message => $message,

      on_parted => sub {
         $cinv->respond( "Parted", level => 1 );
         $self->destroy;
      },
      on_part_error => sub {
         $cinv->responderr( "Cannot part - $_[0]", level => 3 );
      },
   );

   return;
}

sub command_mode
   : Command_description("Change a MODE")
   : Command_arg('mode')
   : Command_arg('args', collect => 1)
{
   my $self = shift;
   my ( $mode, $args ) = @_;

   $self->mode( $mode, @$args );

   return;
}

sub command_topic
   : Command_description("Change the TOPIC")
   : Command_arg('topic?', eatall => 1)
{
   my $self = shift;
   my ( $topic ) = @_;

   if( length $topic ) {
      $self->topic( $topic );
   }
   else {
      $self->push_displayevent( "irc.topic_is", { channel => $self->get_prop_name, topic => $self->get_prop_topic } );
   }

   return;
}

sub command_names
   : Command_description("Print a list of users in the channel")
   : Command_opt('flat=+', desc => "all types of users in one flat list")
{
   my $self = shift;
   my ( $opts, $cinv ) = @_;

   my $occ = $self->get_prop_occupants;

   if( $opts->{flat} ) {
      my @names = map { "$occ->{$_}{flag}$occ->{$_}{nick}" } sort keys %$occ;

      $cinv->respond( "Names: " . CORE::join( " ", @names ) );
      return;
   }

   # Split into groups per flag
   my %occgroups;
   for my $nick_folded ( keys %$occ ) {
      my $flag = substr( $occ->{$nick_folded}{flag}, 0, 1 ); # In case user has several
      push @{ $occgroups{ $flag } }, $nick_folded;
   }

   # TODO: Ought to obtain this from somewhere - NaIRC maybe?
   my %flag_to_desc = (
      '~' => "Founder",
      '&' => "Admin",
      '@' => "Operator",
      '%' => "Halfop",
      '+' => "Voice",
      ''  => "User",
   );

   my $irc = $self->{irc};
   foreach my $flag ( sort { $irc->cmp_prefix_flags( $b, $a ) } keys %occgroups ) {
      my @names = map { "$flag$occ->{$_}{nick}" } sort @{ $occgroups{$flag} };

      my $text = Circle::TaggedString->new( $flag_to_desc{$flag} . ": " );
      $text->append_tagged( CORE::join( " ", @names ), indent => 1 );

      $cinv->respond( $text );
   }

   return;
}

sub command_op
   : Command_description("Give channel operator status to users")
   : Command_arg('users', collect => 1)
{
   my $self = shift;
   my ( $users ) = @_;

   my @users = @$users;
   $self->mode( "+".("o"x@users), @users );

   return;
}

sub command_deop
   : Command_description("Remove channel operator status from users")
   : Command_arg('users', collect => 1)
{
   my $self = shift;
   my ( $users ) = @_;

   my @users = @$users;
   $self->mode( "-".("o"x@users), @users );

   return;
}

sub command_halfop
   : Command_description("Give channel half-operator status to users")
   : Command_arg('users', collect => 1)
{
   my $self = shift;
   my ( $users ) = @_;

   my @users = @$users;
   $self->mode( "+".("h"x@users), @users );

   return;
}

sub command_dehalfop
   : Command_description("Remove channel half-operator status from users")
   : Command_arg('users', collect => 1)
{
   my $self = shift;
   my ( $users ) = @_;

   my @users = @$users;
   $self->mode( "-".("h"x@users), @users );

   return;
}

sub command_voice
   : Command_description("Give channel voice status to users")
   : Command_arg('users', collect => 1)
{
   my $self = shift;
   my ( $users ) = @_;

   my @users = @$users;
   $self->mode( "+".("v"x@users), @users );

   return;
}

sub command_devoice
   : Command_description("Remove channel voice status from users")
   : Command_arg('users', collect => 1)
{
   my $self = shift;
   my ( $users ) = @_;

   my @users = @$users;
   $self->mode( "-".("v"x@users), @users );

   return;
}

sub command_invite
   : Command_description("Invite a new user to the channel")
   : Command_arg('user')
{
   my $self = shift;
   my ( $nick ) = @_;

   $self->invite( $nick );

   return;
}

sub command_kick
   : Command_description("Kick a user from the channel")
   : Command_arg('user')
   : Command_arg('message?', eatall => 1 )
{
   my $self = shift;
   my ( $nick, $message ) = @_;

   $message = "" if !defined $message;

   $self->kick( $nick, $message );

   return;
}

###
# Widget tree
###

sub get_widget_statusbar
{
   my $self = shift;

   my $registry = $self->{registry};
   my $net = $self->{net};

   my $statusbar = $registry->construct(
      "Circle::Widget::Box",
      classes => [qw( status )],
      orientation => "horizontal",
   );

   $statusbar->add( $net->get_widget_netname );

   my $nicklabel = $registry->construct(
      "Circle::Widget::Label",
      classes => [qw( nick )],
   );

   # TODO: This is hideous...
   my $nick = $net->get_prop_nick || $net->{configured_nick};
   my $my_flag = "";
   my $updatenicklabel = sub { $nicklabel->set_prop_text( $my_flag . $nick ) };
   $net->watch_property( "nick",
      on_set => sub { $nick = $_[1]; goto &$updatenicklabel }
   );
   $self->watch_property( "my_flag",
      on_set => sub { $my_flag = $_[1]; goto &$updatenicklabel }
   );
   $updatenicklabel->();

   $statusbar->add( $nicklabel );

   my $modestrlabel = $registry->construct(
      "Circle::Widget::Label",
      classes => [qw( mode )],
   );
   $self->watch_property( "modestr",
      on_updated => sub { $modestrlabel->set_prop_text( $_[1] || "" ) }
   );

   $statusbar->add( $modestrlabel );

   $statusbar->add_spacer( expand => 1 );

   my $countlabel = $registry->construct(
      "Circle::Widget::Label",
      classes => [qw( occupants )],
   );
   $self->watch_property( "occupant_summary",
      on_updated => sub {
         my ( $self, $summary ) = @_;

         my $irc = $self->{irc};
         my $PREFIX_FLAGS = $irc->isupport( "prefix_flags" ) || "";

         my $str = "$summary->{total} users [" .
             CORE::join( " ", map { "$_$summary->{$_}" } grep { $summary->{$_}||0 > 0 } split( m//, $PREFIX_FLAGS ), "" ) .
             "]";

         $countlabel->set_prop_text( $str );
      }
   );

   $statusbar->add( $countlabel );

   return $statusbar;
}

sub get_widget_occupants_completegroup
{
   my $self = shift;

   return $self->{widget_occupants_completegroup} ||= do {
      my $registry = $self->{registry};

      my $widget = $registry->construct(
         "Circle::Widget::Entry::CompleteGroup",
         suffix_sol => ": ",
      );

      my %key_to_nick;
      $self->watch_property( "occupants",
         on_set => sub {
            my ( undef, $occupants ) = @_;
            $widget->set( map { $key_to_nick{$_} = $occupants->{$_}{nick} } keys %$occupants );
         },
         on_add => sub {
            my ( undef, $key, $occ ) = @_;
            $widget->add( $key_to_nick{$key} = $occ->{nick} );
         },
         on_del => sub {
            my ( undef, $key ) = @_;
            $widget->remove( delete $key_to_nick{$key} );
         },
      );

      my $occupants = $self->get_prop_occupants;
      $widget->set( map { $key_to_nick{$_} = $occupants->{$_}{nick} } keys %$occupants );

      $widget;
   };
}

sub get_widget_commandentry
{
   my $self = shift;
   my $widget = $self->SUPER::get_widget_commandentry;

   $widget->add_prop_completions( $self->get_widget_occupants_completegroup );

   return $widget;
}

sub make_widget_pre_scroller
{
   my $self = shift;
   my ( $box ) = @_;

   my $registry = $self->{registry};

   my $topicentry = $registry->construct(
      "Circle::Widget::Entry",
      classes => [qw( topic )],
      on_enter => sub { $self->topic( $_[0] ) },
   );
   $self->watch_property( "topic",
      on_updated => sub { $topicentry->set_prop_text( $_[1] ) }
   );

   $box->add( $topicentry );
}

0x55AA;