Make sure local_context() runs the code only when the context was found
[perl/scripts/xchat.git] / 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 use Xchat::XPI::Utils qw<gui save_context>;
14
15 use constant MAX_MATCHES => 10;
16
17 our $VERSION = '0.05';
18
19 my $ph;
20
21 BEGIN {
22  $Data::Dumper::Indent = 1;
23  $Data::Dumper::Sortkeys = 1;
24 }
25
26 hook_command 'TC', sub {
27  my $guard = save_context;
28  for (get_list 'channels') {
29   set_context $_->{context};
30   gui 'clear';
31  }
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 = strip_code $_->{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;