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 our $VERSION = '0.04';
  15
  16 my $ph;
  17
  18 BEGIN {
  19  $Data::Dumper::Indent = 1;
  20  $Data::Dumper::Sortkeys = 1;
  21 }
  22
  23 hook_command 'TC', sub {
  24  my $oldctxt = get_context;
  25  for (get_list 'channels') {
  26   set_context $_->{context};
  27   command 'GUI COLOR 0';
  28  }
  29  set_context $oldctxt;
  30  return EAT_ALL;
  31 }, {
  32  help_text => 'TC, reset all tab color indicators'
  33 };
  34
  35 sub d { return Dumper @_; }
  36 sub dp { print $ph Dumper(@_), "\n" }
  37
  38 sub warneval { print $ph 'Warning: ' . (join ' ', @ _) }
  39
  40 hook_command 'PERL', sub  {
  41  return EAT_ALL unless defined $_[0][1];
  42  if ($_[0][1] eq '-o') {
  43   return EAT_ALL unless defined $_[1][2];
  44   local $SIG{__WARN__} = \&warneval;
  45   my @result = grep defined, (eval $_[1][2]);
  46   local $SIG{__WARN__} = 'DEFAULT';
  47   if ($@) {
  48    chomp $@;
  49    print $ph "Error: $@\n";
  50   } elsif (@result) {
  51    command join ' ', 'MSG', get_info('channel'), @result;
  52   } else {
  53    print $ph "No output\n";
  54   }
  55  } else {
  56   local $SIG{__WARN__} = \&warneval;
  57   my @result = eval $_[1][1];
  58   local $SIG{__WARN__} = 'DEFAULT';
  59   if ($@) {
  60    chomp $@;
  61    print $ph "Error: $@\n";
  62    return EAT_ALL;
  63   }
  64   @result = ('(empty)') unless @result;
  65   my ($c, @scalars) = (0);
  66   my @refs = grep {
  67       (defined || (push @scalars, '(undef)') && 0)
  68    && (ref || (push @scalars, $_) && 0)
  69    && ((push @scalars, '$REF' . ++$c) || 1)
  70   } @result;
  71   {
  72    local $Data::Dumper::Varname = 'REF';
  73    print $ph 'Return: ', (join ' | ', @scalars), "\n", d @refs;
  74   }
  75  }
  76  return EAT_ALL;
  77 }, {
  78  help_text => 'PERL [-o] <perlexp>, evalute the expression with Perl'
  79 };
  80
  81 hook_command 'URIESCAPE', sub {
  82  return EAT_ALL unless defined $_[0][1];
  83  my ($uri, $out, $protect);
  84  if ($_[0][1] eq '-o') {
  85   $uri = $_[1][2];
  86   $out = 1;
  87  } elsif ($_[0][1] eq '-p') {
  88   $uri = $_[1][2];
  89   $protect = 1;
  90  } else {
  91   $uri = $_[1][1];
  92  }
  93  $uri = encode get_info('charset'), $uri;
  94  $uri =~ s/([^A-Za-z0-9\-_.!~*'():\/])/sprintf("%%%02X",ord($1))/ge;
  95  if ($out) {
  96   command 'SAY ' . $uri;
  97  } else {
  98   $uri =~ s/%/%%/g if $protect;
  99   print $ph $uri, "\n";
 100  }
 101  return EAT_ALL;
 102 }, {
 103  help_text => 'URIESCAPE [-o|-p] <uri>, escape unsafe characters in the URI'
 104 };
 105
 106 hook_command 'WIDE', sub {
 107  my $txt = $_[1][1];
 108  return EAT_ALL unless defined $txt;
 109  $txt =~ s/([\x21-\x7e])/chr 0xfee0 + ord $1/ge;
 110  command 'SAY ' . $txt;
 111  return EAT_ALL;
 112 }, {
 113  help_text => 'WIDE <text>, say text in wide unicode characters'
 114 };
 115
 116 $ph = new Xchat::XPI name   => 'Misc tools',
 117                      tag    => 'Tools',
 118                      desc   => 'Perl interpretor, URI escaper',
 119                      author => 'Vincent Pit (VPIT)',
 120                      email  => 'perl@profvince.com',
 121                      url    => 'http://www.profvince.com';
 122
 123 1;