metabot/extern/cel-bot/CelBot/Plugin/Debug.pm

package CelBot::Plugin::Debug;

use strict;
use constant PLUGIN_TYPE => "debug";

use CelBot::Commands;

use Data::Dump qw( dump );

sub new
{
   my $class = shift;
   my ( $core, $config ) = @_;

   my $self = bless {
      core => $core,
      eval_enabled => 0,
   }, $class;

   return $self;
}

sub print_channel_occupants
{
   my $self = shift;
   my ( $channel, $userflags ) = @_;

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

   $userflags ||= $channel->get_userflags;

   my $str = $channel->name . " occupants:";
   $str .= join( " ", map { ($userflags->{$_}||"") . $_ } sort keys %$userflags );

   $core->log( "DEBUG", "<Debug>", $str );
}

sub on_channel_mode
{
   my $self = shift;
   my ( $channel, $modechar, $value ) = @_;

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

   if( defined $value ) {
      $core->log( "DEBUG", "<Debug>", "MODE: channel ".$channel->name." +$modechar $value" );
   }
   else {
      $core->log( "DEBUG", "<Debug>", "MODE: channel ".$channel->name." -$modechar" );
   }

   my $str = "MODE is now\n";
   my $modes = $channel->get_modes;
   $str .= "  $_ = $modes->{$_}\n" for sort keys %$modes;
   $core->log( "DEBUG", "<Debug>", $str );
}

sub on_channel_usermode
{
   my $self = shift;
   my ( $channel, $user, $flag ) = @_;

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

   if( defined $flag ) {
      $core->log( "DEBUG", "<Debug>", "MODE: channel ".$channel->name." ".$user->nick." => $flag" );
   }
   else {
      $core->log( "DEBUG", "<Debug>", "MODE: channel ".$channel->name." ".$user->nick." X" );
   }

   # $self->print_channel_occupants( $channel );
}

sub on_channel_names
{
   my $self = shift;
   my ( $channel, $usermodes ) = @_;

   $self->print_channel_occupants( $channel, $usermodes );
}

sub on_channel_topic
{
   my $self = shift;
   my ( $channel, $topic, $setby ) = @_;

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

   if( defined $setby ) {
      $core->log( "DEBUG", "<Debug>", "TOPIC: channel ".$channel->name." by $setby\n  $topic" );
   }
   else {
      $core->log( "DEBUG", "<Debug>", "TOPIC: channel ".$channel->name."\n  $topic" );
   }
}

sub on_channel_join
{
   my $self = shift;
   my ( $channel, $user ) = @_;

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

   $core->log( "DEBUG", "<Debug>", "JOIN: channel ".$channel->name." ".$user->nick );

   # $self->print_channel_occupants( $channel );
}

sub on_channel_leave
{
   my $self = shift;
   my ( $channel, $user, $command, $reason ) = @_;

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

   $core->log( "DEBUG", "<Debug>", "LEAVE: channel ".$channel->name." ".$user->nick." - $command ($reason)" );

   # $self->print_channel_occupants( $channel );
}

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

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

   $core->log( "DEBUG", "<Debug>", "CREATE: user ".$user->nick );
}

sub on_user_quit
{
   my $self = shift;
   my ( $user, $reason ) = @_;

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

   $core->log( "DEBUG", "<Debug>", "QUIT: user ".$user->nick." ($reason)" );
}

sub on_user_rename
{
   my $self = shift;
   my ( $user, $oldnick, $newnick ) = @_;

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

   $core->log( "DEBUG", "<Debug>", "NICK: user $oldnick -> $newnick" );
}

sub on_user_host
{
   my $self = shift;
   my ( $user, $ident, $host ) = @_;

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

   $core->log( "DEBUG", "<Debug>", "HOST: user ".$user->nick." ident=$ident host=$host" );
}

sub on_recognise_user
{
   my $self = shift;
   my ( $user, $handle ) = @_;

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

   $core->log( "DEBUG", "<Debug>", "RECOGNISE: ".$user->nick." (".$user->location.") is $handle" );
}

###
# Commands
###

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

   $commands_plugin->register(
      plugin  => $self,
      command => "debug",
      perm    => 'owner',

      subcmds => {
         eval => {
            scope => 'console',

            args => [
               CelBot::Commands::ArgSpec->new( 'EXPR', trailing => 1 ),
            ],

            summary => "Evaluate a Perl expression",
         },
      },

      summary => "Debugging introspection system",
   );
}

sub command_debug
{
   my $self = shift;
   my ( $context, $subcmd ) = @_;

   my $method = "command_debug_$subcmd";
   if( $self->can( $method ) ) {
      return $self->$method( $context );
   }
   else {
      return ( "No such debugging command '$subcmd'" );
   }
}

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

   return "EVAL disabled" unless $self->{eval_enabled};

   my $core = $self->{core};
   my $irc = $core->get_plugin( "irc" );

   # Some useful functions to keep in scope
   local *CORE = sub { $core };
   local *IRC  = sub { $irc };
   local *CHAN = sub { $irc->get_channel( shift ) };
   local *USER = sub { $irc->get_user( shift ) };
   local *PLUGIN = sub { $core->get_plugin( shift ) };

   my $result = eval $context->text;
   if( $@ ) {
      # Might be many lines - trim just the first three at most
      my @lines = split( m/\n/, $@ );
      @lines = @lines[0..3] if @lines > 3;
      return ( "Died: " . join( "\n", @lines ) );
   }
   else {
      my @lines = split( m/\n/, dump( $result ) );
      if( @lines > 20 ) {
         @lines = ( @lines[0..18], "...", $lines[-1] );
      }
      return @lines;
   }
}

###
# Settings
###

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

   $settings_plugin->register(
      type    => 'boolean',
      name    => "eval_enabled",
      perm    => 'owner',

      storage => \$self->{eval_enabled},
   );
}

# Keep perl happy, keep Britain tidy
1;