tools.pl

   1 package Xchat::VPIT::Tools;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Data::Dumper;
   7 use Encode qw/encode/;
   8
   9 use Xchat qw/:all/;
  10
  11 use lib get_info 'xchatdir';
  12 use Xchat::XPI;
  13
  14 use constant MAX_MATCHES => 10;
  15
  16 our $VERSION = '0.05';
  17
  18 my $ph;
  19
  20 BEGIN {
  21  $Data::Dumper::Indent = 1;
  22  $Data::Dumper::Sortkeys = 1;
  23 }
  24
  25 hook_command 'TC', sub {
  26  my $oldctxt = get_context;
  27  for (get_list 'channels') {
  28   set_context $_->{context};
  29   command 'GUI COLOR 0';
  30  }
  31  set_context $oldctxt;
  32  return EAT_ALL;
  33 }, {
  34  help_text => 'TC, reset all tab color indicators'
  35 };
  36
  37 sub d { return Dumper @_; }
  38 sub dp { print $ph Dumper(@_), "\n" }
  39
  40 sub warneval { print $ph 'Warning: ' . (join ' ', @ _) }
  41
  42 hook_command 'PERL', sub  {
  43  return EAT_ALL unless defined $_[0][1];
  44  if ($_[0][1] eq '-o') {
  45   return EAT_ALL unless defined $_[1][2];
  46   local $SIG{__WARN__} = \&warneval;
  47   my @result = grep defined, (eval $_[1][2]);
  48   local $SIG{__WARN__} = 'DEFAULT';
  49   if ($@) {
  50    chomp $@;
  51    print $ph "Error: $@\n";
  52   } elsif (@result) {
  53    command join ' ', 'MSG', get_info('channel'), @result;
  54   } else {
  55    print $ph "No output\n";
  56   }
  57  } else {
  58   local $SIG{__WARN__} = \&warneval;
  59   my @result = eval $_[1][1];
  60   local $SIG{__WARN__} = 'DEFAULT';
  61   if ($@) {
  62    chomp $@;
  63    print $ph "Error: $@\n";
  64    return EAT_ALL;
  65   }
  66   @result = ('(empty)') unless @result;
  67   my ($c, @scalars) = (0);
  68   my @refs = grep {
  69       (defined || (push @scalars, '(undef)') && 0)
  70    && (ref || (push @scalars, $_) && 0)
  71    && ((push @scalars, '$REF' . ++$c) || 1)
  72   } @result;
  73   {
  74    local $Data::Dumper::Varname = 'REF';
  75    print $ph 'Return: ', (join ' | ', @scalars), "\n", d @refs;
  76   }
  77  }
  78  return EAT_ALL;
  79 }, {
  80  help_text => 'PERL [-o] <perlexp>, evalute the expression with Perl'
  81 };
  82
  83 hook_command 'URIESCAPE', sub {
  84  return EAT_ALL unless defined $_[0][1];
  85  my ($uri, $out, $protect);
  86  if ($_[0][1] eq '-o') {
  87   $uri = $_[1][2];
  88   $out = 1;
  89  } elsif ($_[0][1] eq '-p') {
  90   $uri = $_[1][2];
  91   $protect = 1;
  92  } else {
  93   $uri = $_[1][1];
  94  }
  95  $uri = encode get_info('charset'), $uri;
  96  $uri =~ s/([^A-Za-z0-9\-_.!~*'():\/])/sprintf("%%%02X",ord($1))/ge;
  97  if ($out) {
  98   command 'SAY ' . $uri;
  99  } else {
 100   $uri =~ s/%/%%/g if $protect;
 101   print $ph $uri, "\n";
 102  }
 103  return EAT_ALL;
 104 }, {
 105  help_text => 'URIESCAPE [-o|-p] <uri>, escape unsafe characters in the URI'
 106 };
 107
 108 hook_command 'WIDE', sub {
 109  my $txt = $_[1][1];
 110  return EAT_ALL unless defined $txt;
 111  $txt =~ s/([\x21-\x7e])/chr 0xfee0 + ord $1/ge;
 112  command 'SAY ' . $txt;
 113  return EAT_ALL;
 114 }, {
 115  help_text => 'WIDE <text>, say text in wide unicode characters'
 116 };
 117
 118 hook_command 'HGREP', sub {
 119  my $txt = $_[1][1];
 120  return EAT_ALL unless defined $txt;
 121  $txt = qr/$txt/i;
 122  my @matches;
 123  for (get_list 'users') {
 124   my $host = $_->{host};
 125   next unless $host =~ /$txt/;
 126   push @matches, [ $_->{nick}, $host ];
 127  }
 128  my $nbr = @matches;
 129  print $ph ($nbr == 0 ? 'No' : $nbr)
 130            . ' match' . ('es' x ($nbr > 1))
 131            . ' to ' . $txt;
 132  if (@matches < MAX_MATCHES) {
 133   print $ph +(':' x ($nbr > 0)) . "\n";
 134   print $ph "\002$_->[0]\002 ($_->[1])\n" for @matches;
 135  } else {
 136   print $ph " (too many of them, omitted)\n";
 137  }
 138  return EAT_ALL;
 139 }, {
 140  help_text => 'HGREP <text>, print users in the current context whose hostname matches text'
 141 };
 142
 143 $ph = Xchat::XPI->new(
 144  name   => 'Misc tools',
 145  tag    => 'Tools',
 146  desc   => 'Perl interpretor, URI escaper',
 147  author => 'Vincent Pit (VPIT)',
 148  email  => 'perl@profvince.com',
 149  url    => 'http://www.profvince.com',
 150 );
 151
 152 1;