--- /dev/null
+package Xchat::XPI;
+
+use strict;
+use warnings;
+
+use Tie::RefHash;
+
+use Xchat;
+
+our $VERSION = '0.03';
+
+use constant { COLOR_TAG => "\00307" };
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class || return;
+ return if @_ % 2;
+ my %opts = @_;
+
+ my $caller = (caller 0)[0];
+ $opts{tag} ||= ($caller =~ /([^:]*):*$/) ? $1 : 'UNKNOWN';
+ $opts{name} ||= $opts{tag};
+ $opts{desc} ||= $opts{name};
+ $opts{version} ||= do { no strict 'refs'; ${$caller.'::VERSION'} }
+ || '0.01';
+
+ my $email = $opts{email};
+ $email = '<' . $email . '>' if defined $email;
+ my $desc = join ', ', grep defined, $opts{author}, $email, $opts{url};
+ $desc = ' (' . $desc . ')' if length $desc;
+ $opts{banner} = $opts{desc} . $desc;
+
+ my $ph = bless \do { local *PH }, $class;
+ tie *$ph, $ph, @_;
+
+ *$ph->{$_} = $opts{$_} for qw/tag name version desc author email url banner/;
+ *$ph->{buf} = '';
+
+ Xchat::register(@opts{qw/name version banner/}, sub {
+ $ph->flush;
+ if (*$ph->{atexit_id}) {
+ my @callbacks = sort { *$ph->{atexit}{$b} <=> *$ph->{atexit}{$a} }
+ keys %{*$ph->{atexit}};
+ $_->($ph) for @callbacks;
+ }
+ undef $ph;
+ });
+ $ph->add_atexit($opts{unload}) if $opts{unload};
+
+ $ph->print("\002", $ph->name, ' v', $ph->version,
+ " loaded\002 (", $ph->banner, ")\n");
+
+ return $ph;
+}
+
+sub tag {
+ my $ph = shift;
+ return unless $ph;
+ return *$ph->{tag};
+}
+
+sub name {
+ my $ph = shift;
+ return unless $ph;
+ return *$ph->{name};
+}
+
+sub version {
+ my $ph = shift;
+ return unless $ph;
+ return *$ph->{version};
+}
+
+sub desc {
+ my $ph = shift;
+ return unless $ph;
+ return *$ph->{desc};
+}
+
+sub author {
+ my $ph = shift;
+ return unless $ph;
+ return *$ph->{author};
+}
+
+sub email {
+ my $ph = shift;
+ return unless $ph;
+ return *$ph->{email};
+}
+
+sub url {
+ my $ph = shift;
+ return unless $ph;
+ return *$ph->{url};
+}
+
+sub banner {
+ my $ph = shift;
+ return unless $ph;
+ return *$ph->{banner};
+}
+
+sub print {
+ my $ph = shift;
+ return unless $ph;
+ my $ret = 0;
+ my $data = join '', *$ph->{buf},
+ grep defined,
+ (@_) ? @_ : ((defined) ? $_ : '');
+ while ((my $i = index $data, "\n") >= 0) {
+ Xchat::print(COLOR_TAG . $ph->tag . "\t" . (substr $data, 0, ($i + 1), ''));
+ $ret = 1;
+ }
+ *$ph->{buf} = $data;
+ return $ret;
+}
+
+sub printf { shift->print(sprintf @_) }
+
+sub flush {
+ my ($ph) = @_;
+ return unless $ph;
+ $ph->print("\n") if length $ph->{buf};
+}
+
+sub add_atexit {
+ my ($ph, $callback) = @_;
+ return unless $ph && $callback && ref $callback eq 'CODE';
+ if (!*$ph->{atexit_id}) {
+ tie my %h, 'Tie::RefHash';
+ *$ph->{atexit} = \%h;
+ }
+ return *$ph->{atexit}{$callback} = ++*$ph->{atexit_id};
+}
+
+sub remove_atexit {
+ my ($ph, $callback) = @_;
+ return unless $ph && $callback;
+ if (exists *$ph->{atexit}{$callback}) {
+ delete *$ph->{atexit}{$callback};
+ return 1;
+ }
+ return 0;
+}
+
+sub TIEHANDLE {
+ my $ph = shift;
+ ((defined $ph && $ph->isa(__PACKAGE__))
+ ? $ph
+ : shift->new(@_));
+}
+
+sub PRINT { shift->print(@_) }
+
+sub PRINTF { shift->printf(@_) }
+
+my $ph = new __PACKAGE__, name => 'Extended Xchat Perl Interface',
+ desc => 'Adds extended support for Perl scripts',
+ author => 'Vincent Pit (VPIT)',
+ email => 'perl@profvince.com',
+ url => 'http://www.profvince.com';
+
+1;
--- /dev/null
+package Xchat::XPI::Events;
+
+use strict;
+use warnings;
+
+use Xchat qw/:all/;
+
+use lib get_info 'xchatdir';
+use Xchat::XPI;
+
+use constant {
+ DEFAULT_DELAY => 1000
+};
+
+our $VERSION = '0.03';
+
+my $ph;
+
+sub delay {
+ my $d = shift;
+ $d = (defined $d) ? int $d : DEFAULT_DELAY;
+ return hook_timer $d, sub {
+ my ($cb, $data) = @{$_[0]};
+ &$cb($data);
+ return REMOVE;
+ }, { data => \@_ };
+}
+
+my %reorder;
+
+sub filter {
+ return unless @_ == 3;
+ not defined and return for @_;
+ my ($cb, $to) = @_[1, 2];
+ return hook_print $_[0], sub {
+ my @args = @{$_[0]};
+ if ($cb->(@args)) {
+ $reorder{$to}->(@args) if exists $reorder{$to};
+ emit_print $to, @args;
+ return EAT_ALL;
+ } else {
+ return EAT_NONE;
+ }
+ }
+}
+
+use base qw/Exporter/;
+
+our @EXPORT = ();
+our %EXPORT_TAGS = (
+ 'funcs' => [ qw/delay filter/ ],
+ 'consts' => [ qw/DEFAULT_DELAY/ ]
+);
+our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
+
+$ph = new Xchat::XPI name => 'Extended Xchat Perl Interface :: Events',
+ tag => 'XPI::Events',
+ desc => 'More events handlers',
+ author => 'Vincent Pit (VPIT)',
+ email => 'perl@profvince.com',
+ url => 'http://www.profvince.com';
+
+1;
--- /dev/null
+package Xchat::XPI::Net;
+
+use strict;
+use warnings;
+
+use IO::Socket::INET;
+
+use Net::DNS;
+
+use Xchat qw/:all/;
+
+use lib get_info 'xchatdir';
+use Xchat::XPI qw/register init/;
+
+our $VERSION = '0.02';
+
+my ($ph, $res);
+
+BEGIN {
+ $res = Net::DNS::Resolver->new;
+
+ my $timeout = 5;
+ $res->tcp_timeout($timeout);
+ $res->udp_timeout($timeout);
+
+ my $nameservers = '';
+ $res->nameservers( [ split ' ', $nameservers ] ) if $nameservers;
+}
+
+sub resolve {
+ my ($host, $callback) = @_[0, 1];
+ return unless $host && $callback;
+ my $args = $_[2];
+ my $sock = $res->bgsend($host);
+ return unless $sock;
+ $sock->autoflush(1);
+ my $hook = Xchat::hook_fd($sock, \&_dns_recv, { flags => FD_READ, data => [ $callback, $args ] } );
+ return $hook;
+}
+
+sub _dns_recv {
+ my $fd = $_[0];
+ my ($callback, $args) = @{$_[2]};
+ my $p = $res->bgread($fd);
+ $fd->shutdown(2);
+ close $fd;
+ undef $fd;
+ &$callback($p, $args);
+ return REMOVE;
+}
+
+my %whois_servers = (
+ domain => {
+ default => 'whois.internic.net',
+ arpa => 'whois.arin.net',
+# mil => 'whois.nic.mil',
+ },
+ ipv4 => { default => 'whois.ripe.net' },
+ ipv6 => { default => 'whois.6bone.net' }
+);
+
+sub whois {
+ my ($host, $callback) = @_[0, 1];
+ return unless $host && $callback;
+ my $args = $_[2];
+ my $server;
+ if ($host =~ /^\s*\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}(\/\d{1,2})?$/) {
+ $server = $whois_servers{ipv4}{default};
+ } elsif ($host =~ /^\s*[\d:]*(\/\d{1,2})?\s*$/) {
+ $server = $whois_servers{ipv6}{default};
+ } elsif ($host =~ /([^\.]+)\.+([a-z]+)\.*$/) {
+ $host = $1.'.'.$2;
+ $server = $whois_servers{domain}{$2};
+ $server = $whois_servers{domain}{default} if !$server;
+ }
+ return unless $server;
+ my $hook;
+
+# resolve($server, \&_whois_send, [ \$hook, $host, $callback, $args ] );
+# return \$hook;
+#}
+#
+#sub _whois_send {
+# my $p = $_[0];
+# my @a = grep { $_->type eq 'A' && $_->address } $p->answer;
+# return unless @a;
+# my ($hookref, $host, $callback, $args) = @{$_[1]};
+# my $server = $a[rand(@a)]->address;
+
+ my $sock = IO::Socket::INET->new(
+ PeerAddr => $server,
+ PeerPort => 43,
+ Proto => 'tcp'
+ ) or return;
+ $sock->autoflush(1);
+ print $sock "$host\x0D\x0A";
+ $sock->shutdown(1); # stop writing
+ $hook = Xchat::hook_fd($sock, \&_whois_recv, { flags => FD_READ, data => [ $callback, $args ] } );
+ return $hook;
+}
+
+sub _whois_recv {
+ my $fd = $_[0];
+ my ($callback, $args) = @{$_[2]};
+ my $raw = do { local $/; <$fd>; };
+ $fd->shutdown(2);
+ close $fd;
+ undef $fd;
+ &$callback($raw, $args);
+ return REMOVE;
+}
+
+use base qw/Exporter/;
+
+our @EXPORT = ();
+our %EXPORT_TAGS = ('funcs' => [ qw/resolve whois/ ]);
+our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
+
+$ph = new Xchat::XPI name => 'Extended Xchat Perl Interface :: Net',
+ tag => 'XPI::Net',
+ desc => 'Asynchronous network tools',
+ author => 'Vincent Pit (VPIT)',
+ email => 'perl@profvince.com',
+ url => 'http://www.profvince.com';
+
+1;
--- /dev/null
+package Xchat::XPI::Utils;
+
+use strict;
+use warnings;
+
+use Xchat qw/:all/;
+
+use lib get_info 'xchatdir';
+use Xchat::XPI qw/register init/;
+
+our $VERSION = '0.01';
+
+my $ph;
+
+sub dye_nick {
+ my ($nick, $col) = ($_[0], 0);
+ $col += ord for split //, $nick;
+ my @rcolors = (nickcmp(get_info('version'), '2.4.0') < 0)
+ ? (3, 4, 6, 8, 9, 10, 11, 12, 13)
+ : (19, 20, 22, 24, 25, 26, 27, 28, 29);
+ $col %= @rcolors;
+ return sprintf "\003%d%s", $rcolors[$col], $nick;
+}
+
+use base qw/Exporter/;
+
+our @EXPORT = ();
+our %EXPORT_TAGS = ('funcs' => [ qw/dye_nick/ ]);
+our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
+
+$ph = new Xchat::XPI name => 'Extended Xchat Perl Interface :: Utils',
+ tag => 'XPI::Utils',
+ desc => 'Utility functions',
+ author => 'Vincent Pit (VPIT)',
+ email => 'perl@profvince.com',
+ url => 'http://www.profvince.com';
+
+1;
--- /dev/null
+package Xchat::VPIT::Clones;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw/dualvar/;
+
+use Xchat qw/:all/;
+
+use lib get_info 'xchatdir';
+use Xchat::XPI;
+use Xchat::XPI::Events qw/delay/;
+
+use constant {
+ JOIN_DELAY => 1000,
+ PRE => ' ',
+ POST => "\n"
+};
+
+our $VERSION = '0.04';
+
+my ($ph, %users, %fetched);
+my $extractor = PRE . '(.+?)' . POST;
+$extractor = qr/$extractor/;
+
+sub clone_enter_str {
+ my ($host, $nick, $clones) = @_;
+ my @clones = $clones =~ /$extractor/g;
+ return "\002$nick\002 ($host) is a clone of : \002@clones\002\n";
+}
+
+sub clone_leave_str {
+ my ($host, $nick, $clones) = @_;
+ my @clones = $clones =~ /$extractor/g;
+ return "\002$nick\002 ($host) has "
+ . int($clones) . ' clone' . ($clones > 1 ? 's' : '')
+ . " left : \002@clones\002\n";
+}
+
+sub clone_list_str {
+ my ($host, $clones) = @_;
+ my @clones = $clones =~ /$extractor/g;
+ return "Clones ($host) : \002@clones\002\n";
+}
+
+sub host {
+ my $userhost = lc $_[0];
+ my ($host) = $userhost =~ /@([^@]+)$/;
+ return $host || $userhost;
+}
+
+sub add {
+ my ($nick, $host, $serv, $chan) = @_;
+ my $hosts = $users{$serv}{$chan};
+ $users{$serv}{$chan} = $hosts = { } if not defined $hosts;
+ my $clones = $hosts->{$host};
+ $nick = PRE . $nick . POST;
+ if (defined $clones) {
+ if ((index $clones, $nick) < $[) {
+ $hosts->{$host} = dualvar int($clones) + 1, $clones . $nick;
+ }
+ } else {
+ $clones = dualvar 0, '';
+ $hosts->{$host} = dualvar 1, $nick;
+ }
+ return $clones;
+}
+
+sub remove {
+ my ($nick, $host, $serv, $chan) = @_;
+ my $hosts = $users{$serv}{$chan};
+ return 0 unless $hosts;
+ my $clones = $hosts->{$host};
+ return 0 unless $clones;
+ $nick = PRE . $nick . POST;
+ if ((my $off = index $clones, $nick) >= $[) {
+ my $count = int $clones;
+ if ($count > 1) {
+ substr $clones, $off, length $nick, '';
+ return $hosts->{$host} = dualvar $count - 1,
+ $clones;
+ } else {
+ delete $hosts->{$host};
+ }
+ }
+ return 0;
+}
+
+sub replace {
+ my ($old, $new, $host, $serv, $chan) = @_;
+ my $hosts = $users{$serv}{$chan};
+ $users{$serv}{$chan} = $hosts = { } unless defined $hosts;
+ my $clones = $hosts->{$host};
+ ($old, $new) = map { PRE . $_ . POST } $old, $new;
+ if (defined $clones && (my $off = index $clones, $old) >= $[) {
+ my $count = int $clones;
+ substr $clones, $off, length $old, '';
+ $hosts->{$host} = dualvar $count, $clones . $new;
+ } else {
+ $hosts->{$host} = dualvar 1, $new;
+ }
+}
+
+sub scan {
+ my ($serv, $chan) = @_;
+ return unless $fetched{$serv}{$chan};
+ my $hosts = $users{$serv}{$chan};
+ my $count = 0;
+ while (my ($host, $clones) = each %$hosts) {
+ if ($clones > 1) {
+ ++$count;
+ print $ph clone_list_str $host, $clones;
+ }
+ }
+ return $count;
+}
+
+sub flush {
+ my ($serv, $chan) = @_;
+ return 0 unless $serv && $chan && $fetched{$serv}{$chan};
+ delete $users{$serv}{$chan};
+ delete $users{$serv} unless keys %{$users{$serv}};
+ delete $fetched{$serv}{$chan};
+ delete $fetched{$serv} unless keys %{$fetched{$serv}};
+ return 1;
+}
+
+sub fetch {
+ my ($serv, $chan) = @_;
+ my @users = grep { defined $_->{host} and length $_->{host} }
+ get_list 'users';
+ if (@users) {
+ add $_->{nick}, host($_->{host}), $serv, $chan for @users;
+ $fetched{$serv}{$chan} = 1;
+ }
+ return scalar @users;
+}
+
+hook_server '315', sub { # WHO end
+ my $serv = get_info 'server';
+ my $chan = lc $_[0][3];
+ return EAT_NONE if $fetched{$serv}{$chan};
+ my $oldctxt = get_context;
+ set_context $chan, $serv or return EAT_NONE;
+ fetch $serv, $chan;
+ scan $serv, $chan;
+ set_context $oldctxt;
+ return EAT_NONE;
+};
+
+# On join, the who finishes sometimes before the tab opens, so the scan result
+# isn't always displayed in the proper context. Hence the delay()
+
+hook_server 'JOIN', sub {
+ my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
+ my $serv = get_info 'server';
+ my $chan = lc substr $_[0][2], 1; # starts with colon
+ my $clones = add $nick, host($userhost), $serv, $chan;
+ if ($clones > 0) {
+ my $oldctxt = get_context;
+ if (set_context $chan, $serv) {
+ print $ph clone_enter_str $userhost, $nick, $clones;
+ set_context $oldctxt;
+ } else {
+ delay JOIN_DELAY, sub {
+ my $oldctxt = get_context;
+ return unless set_context $chan, $serv;
+ print $ph clone_enter_str $userhost, $nick, $clones;
+ set_context $oldctxt;
+ };
+ }
+ }
+ return EAT_NONE;
+};
+
+hook_server 'KICK', sub {
+ my $nick = $_[0][3];
+ my $serv = get_info 'server';
+ my $chan = lc $_[0][2];
+ if (nickcmp get_info('nick'), $nick) {
+ my $userinfo = user_info $nick;
+ return EAT_NONE unless $userinfo;
+ my $userhost = $userinfo->{host};
+ my $clones = remove $nick, host($userhost), $serv, $chan;
+ print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
+ } else {
+ flush $serv, $chan;
+ }
+ return EAT_NONE;
+};
+
+hook_server 'PART', sub {
+ my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
+ my $serv = get_info 'server';
+ my $chan = lc $_[0][2];
+ if (nickcmp get_info('nick'), $nick) {
+ my $clones = remove $nick, host($userhost), $serv, $chan;
+ print $ph clone_leave_str $userhost, $nick, $clones if $clones > 0;
+ } else {
+ flush $serv, $chan;
+ }
+ return EAT_NONE;
+};
+
+hook_server 'QUIT', sub {
+ my ($nick, $userhost) = ($_[0][0] =~ /^:([^!]+)!(.*)/);
+ my $serv = get_info 'server';
+ my @chans = map { [ lc $_->{channel}, $_->{context} ] }
+ grep { $_->{type} eq 2 && $_->{server} eq $serv }
+ get_list 'channels';
+ if (nickcmp get_info('nick'), $nick) {
+ my $oldctxt = get_context;
+ my $host = host $userhost;
+ for (@chans) {
+ my $clones = remove $nick, $host, $serv, $_->[0];
+ if ($clones > 0) {
+ set_context $_->[1] or next;
+ print $ph clone_leave_str $userhost, $nick, $clones;
+ }
+ }
+ set_context $oldctxt;
+ } else {
+ flush $serv, $_->[0] for @chans;
+ }
+ return EAT_NONE;
+};
+
+hook_print 'Disconnected', sub {
+ my %servers = map { $_->{server} => 1 }
+ grep { $_->{flags} & 9 && not $_->{flags} & 2 }
+ get_list 'channels';
+ delete $users{$_} for grep { !$servers{$_} } keys %users;
+ delete $fetched{$_} for grep { !$servers{$_} } keys %fetched;
+ return EAT_NONE;
+};
+
+sub nick_cb {
+ my ($old, $new) = @{$_[0]};
+ my $userinfo = user_info $new;
+ replace $old => $new, host($userinfo->{host}),
+ get_info('server'), lc get_info('channel') if $userinfo;
+ return EAT_NONE;
+}
+
+hook_print $_, \&nick_cb for ('Change Nick', 'Your Nick Changing');
+
+hook_command 'CLSCAN', sub {
+ my ($serv, $chan) = (get_info('server'), lc get_info('channel'));
+ if (!$fetched{$serv}{$chan} && !fetch($serv, $chan)) {
+ print $ph "Data still not available\n";
+ } elsif (!scan($serv, $chan)) {
+ print $ph "No clones found\n";
+ }
+ return EAT_ALL;
+}, {
+ help_text => 'Scan for clones in the current channel'
+};
+
+$ph = new Xchat::XPI name => 'Clones scanner',
+ tag => 'Clones',
+ desc => 'Automatic & on-demand clones scanner',
+ author => 'Vincent Pit (VPIT)',
+ email => 'perl@profvince.com',
+ url => 'http://www.profvince.com',
+ unload => sub { undef %users };
+
+1;
--- /dev/null
+package Xchat::VPIT::Highlight;
+
+use strict;
+use warnings;
+
+use Xchat qw/:all/;
+
+use lib get_info 'xchatdir';
+use Xchat::XPI;
+use Xchat::XPI::Events qw/filter/;
+
+our $VERSION = '0.02';
+
+my $ph;
+
+sub guihl {
+ command 'GUI FLASH';
+ command 'GUI COLOR 3';
+}
+
+hook_print 'Private Message to Dialog', sub { guihl; return EAT_NONE };
+
+my %words = (
+ '#cpantesters' => [ qw/Linux-SysInfo MorseSignals Regexp-Wildcards Scalar-Vec-Util Sub-Prototype-Util Test-Valgrind Variable-Magic with- B-RecDeparse Sub-Nary indirect- subs-auto/ ]
+);
+
+for (keys %words) {
+ my $rx = '(?:' . (join '|', @{$words{$_}}) . ')';
+ $words{$_} = qr/$rx/;
+}
+
+filter 'Channel Action' => sub {
+ my $chan = lc get_info 'channel';
+ if ($words{$chan} and $_[1] =~ /$words{$chan}/) {
+ guihl;
+ 1;
+ } else {
+ 0;
+ }
+} => 'Channel Action Hilight';
+
+$ph = new Xchat::XPI name => 'Smart highlighting',
+ tag => 'HL',
+ desc => 'Highlight on private messages',
+ author => 'Vincent Pit (VPIT)',
+ email => 'perl@profvince.com',
+ url => 'http://www.profvince.com';
+
+1;
+
--- /dev/null
+package Xchat::VPIT::MPD;
+
+use strict;
+use warnings;
+
+use Audio::MPD;
+
+use Xchat qw/:all/;
+
+use lib get_info 'xchatdir';
+use Xchat::XPI;
+
+our $VERSION = 0.04;
+
+my $ph;
+
+hook_command $_, sub {
+ my $mpd = Audio::MPD->new;
+ unless ($mpd) {
+ print $ph "Couldn't connect to the MPD server\n";
+ return EAT_ALL;
+ }
+
+ my $status = $mpd->status;
+ unless ($status) {
+ print $ph "MPD doesn't seem to be running\n";
+ return EAT_ALL;
+ }
+ if ($status->state eq 'stop') {
+ print $ph "MPD is stopped\n";
+ return EAT_ALL;
+ }
+
+ my $song = $mpd->current;
+ my $title;
+ if ($title = $song->title) {
+ $title = $_ . ' - ' . $title for grep defined, $song->album, $song->artist;
+ } else {
+ $title = $song->file;
+ $title =~ s!\.\w+$!!;
+ $title = $1 if $title =~ m!/([^/]*)$!;
+ }
+
+ my $time = $status->time;
+ my $duration = sprintf '[%d:%02d/%d:%02d]',
+ $time->sofar_mins, $time->sofar_secs,
+ $time->total_mins, $time->total_secs;
+ command 'ACTION np: ' . $title . ' ' . $duration;
+
+ return EAT_ALL;
+}, {
+ help_text => "$_, output which song is currently played by mpd"
+} for qw/MPD NP/;
+
+$ph = new Xchat::XPI name => 'MPD Client',
+ tag => 'MPD',
+ desc => 'Music Player Daemon client',
+ author => 'Vincent Pit (VPIT)',
+ email => 'perl@profvince.com',
+ url => 'http://www.profvince.com';
+
+1;
--- /dev/null
+package Xchat::VPIT::Net;
+
+use strict;
+use warnings;
+
+use List::Util qw/max/;
+use Locale::Country qw/code2country/;
+
+use Xchat qw/:all/;
+
+use lib get_info 'xchatdir';
+use Xchat::XPI;
+use Xchat::XPI::Net qw/resolve whois/;
+
+our $VERSION = '0.02';
+
+my $ph;
+
+sub parse_url {
+ local $_ = $_[0];
+ return unless defined;
+ my %h = ();
+ if (s/^([^:]*)://) { $h{proto} = lc $1; }
+ ($_, my @path) = grep length, (split m!/!);
+ return unless defined;
+ if (s/:([0-9]*)$// && length $1) { $h{port} = $1; }
+ if (s/(.*)@([^@]*)$/$2/) { ($h{user}, $h{passwd}) = split /:/, $1, 2; }
+ $h{host} = lc;
+ $h{path} = \@path if @path;
+ return \%h;
+}
+
+sub output {
+ my ($motif, $head, @strings) = @_;
+ $head = join ' ', ($motif x 3), $head, ($motif x 3);
+ if (@strings) {
+ my $l = max(map length, @strings) - length($head) - 1; # -1 for CR
+ $head .= ($motif x $l) if $l > 0;
+ }
+ print $ph "\002$head\n", @strings;
+}
+
+hook_command 'DIG', sub {
+ my @reqs = @{$_[0]};
+ shift @reqs;
+ return EAT_ALL unless @reqs;
+ my @users = get_info('users');
+ my $context = get_context;
+ for (@reqs) {
+ my $info = user_info $_;
+ my $req = parse_url($info ? $info->{host} : $_);
+ resolve $req->{host}, \&dig_print, [ $context, $req ];
+ }
+ return EAT_ALL;
+}, {
+ help_text => 'DIG <ip(s)/hostname(s)>, resolve given names/addresses'
+};
+
+sub dig_print {
+ my $p = $_[0];
+ my ($context, $req) = @{$_[1]};
+ my $oldctxt = get_context;
+ set_context $context;
+ if ($p) {
+ my @a = $p->answer;
+ if (@a) {
+ output '-', 'Results for ' . $req->{host},
+ map { $_->string . "\n" } (@a, $p->authority, $p->additional);
+ } else {
+ output '*', 'Resolution failed for ' . $req->{host},
+ map {
+ $_->mname . ' IN SOA ' . $_->rname . "\n",
+ join ' ', 'serial:' . $_->serial, 'ref:' . $_->refresh,
+ 'ret:' . $_->retry, 'exp:' . $_->expire,
+ 'min:' . $_->minimum . "\n";
+ } grep { $_->type eq 'SOA' } $p->authority;
+ }
+ } else {
+ print $ph 'Request ' . $req->{host} . " timed out\n";
+ }
+ set_context $oldctxt;
+}
+
+hook_command 'NETWHOIS', sub {
+ my @reqs = @{$_[0]};
+ shift @reqs;
+ return EAT_ALL unless @reqs;
+ my $context = get_context;
+ for (@reqs) {
+ my $info = user_info $_;
+ my $req = parse_url($info ? $info->{host} : $_);
+ whois $req->{host}, \&netwhois_print, [ $context, $req ];
+ }
+ return EAT_ALL;
+}, {
+ help_text => 'NETWHOIS <ip(s)/hostname(s)>, retrieve domain/ip information'
+};
+
+sub netwhois_print {
+ my $raw = $_[0];
+ my ($context, $req) = @{$_[1]};
+ my $oldctxt = get_context;
+ set_context $context;
+ if ($raw) {
+ $raw =~ s/.*(Domain|inetnum)/$1/s;
+ $raw =~ s/[\r\n]*\>\>\>.*//s;
+ output '-', 'Results for ' . $req->{host},
+ map {
+ s/^\s+//; s/\s+$//;
+ $_ . "\n";
+ } grep { !/^\s*(#|%)/ } split /\r?\n/, $raw;
+ } else {
+ output '*', 'No results for ' . $req->{host};
+ }
+ set_context $oldctxt;
+}
+
+hook_command 'TLD', sub {
+ my @reqs = @{$_[0]};
+ shift @reqs;
+ return EAT_ALL unless @reqs;
+ for (@reqs) {
+ my $info = user_info $_;
+ my $host = parse_url($info ? $info->{host} : $_)->{host};
+ my ($tld) = $host =~ /\.([a-z]+)\.*$/;
+ next unless $tld;
+ my $name = code2country $tld;
+ print $ph $tld . ' is ' . ($name ? $name : 'unknown') . "\n";
+ }
+ return EAT_ALL;
+}, {
+ help_text => 'TLD <hostname(s)>, give the TLD text representation of the hosts'
+};
+
+$ph = new Xchat::XPI name => 'Networking tools',
+ tag => 'Net',
+ desc => 'DNS & Whois clients, TLD names',
+ author => 'Vincent Pit (VPIT)',
+ email => 'perl@profvince.com',
+ url => 'http://www.profvince.com';
+
+1;
--- /dev/null
+package Xchat::VPIT::Opers;
+
+use strict;
+use warnings;
+
+use Xchat qw/:all/;
+
+use lib get_info 'xchatdir';
+use Xchat::XPI;
+
+our $VERSION = '0.03';
+
+my ($ph, %opers);
+
+sub print_op { print $ph "\002$_[0]\002 ($_[1]) \002is an IRC operator\n"; 1 }
+
+hook_server '352', sub {
+ return EAT_NONE unless (rindex $_[0][8], '*') >= 0;
+ my $serv = get_info 'server';
+ my $nick = $_[0][7];
+ if (!$opers{$serv}{$nick}) {
+ $opers{$serv}{$nick} = 1;
+ my $host = $_[0][4].'@'.$_[0][5];
+ my %chans;
+ push @{$chans{$_->{type}}}, $_ for grep { $_->{server} eq $serv }
+ get_list 'channels';
+ my $oldctxt = get_context;
+ my $onachan = grep { $_ } map {
+ set_context($_->{context}) && user_info($nick) && print_op($nick, $host)
+ } @{$chans{2}};
+ do {
+ set_context($_->{context}) && print_op($nick, $host)
+ } for ($onachan ? () : @{$chans{1}}),
+ grep { !nickcmp($_->{channel}, $nick) } @{$chans{3}};
+ set_context $oldctxt;
+ }
+ return EAT_NONE;
+};
+
+hook_print 'Disconnected', sub {
+ my %servers = map { $_->{server} => 1 }
+ grep { $_->{flags} & 9 && not $_->{flags} & 2 }
+ get_list 'channels';
+ delete $opers{$_} for grep { !$servers{$_} } keys %opers;
+ return EAT_NONE;
+};
+
+hook_server 'QUIT', sub {
+ my ($nick) = ($_[0][0] =~ /^:([^!]+)!/);
+ my $serv = get_info 'server';
+ delete $opers{$serv}{$nick};
+ return EAT_NONE;
+};
+
+sub nick_cb {
+ my ($old, $new) = @{$_[0]};
+ my $ops = $opers{get_info 'server'};
+ if ($ops && $ops->{$old}) {
+ $ops->{$new} = 1;
+ delete $ops->{$old};
+ }
+ return EAT_NONE;
+}
+
+hook_print $_, \&nick_cb for ('Change Nick', 'Your Nick Changing');
+
+hook_command 'OPSCAN', sub {
+ my $serv = get_info 'server';
+ if (!$opers{$serv}) {
+ print $ph "No information for this network yet\n";
+ return EAT_ALL;
+ }
+ my ($chan, $isnet) = (get_info('channel'), 0);
+ for (get_list 'channels') {
+ if ($_->{type} eq 1 && $_->{channel} eq $chan) { $isnet = 1; last; }
+ }
+ my ($name, @ops) = ($isnet) ? ('network', keys %{$opers{$serv}})
+ : ('channel', map { $_->{nick} }
+ grep { $opers{$serv}{$_->{nick}} }
+ get_list 'users');
+ if (@ops) {
+ print $ph 'IRC operators on this '.$name." : \002@ops\n";
+ } else {
+ print $ph 'No IRC operators on this '.$name."\n";
+ }
+ return EAT_ALL;
+}, {
+ help_text => 'OPSCAN, scan for IRC operators in the current channel'
+};
+
+$ph = new Xchat::XPI name => 'Operators',
+ tag => 'Opers',
+ desc => 'IRC operators scanner',
+ author => 'Vincent Pit (VPIT)',
+ email => 'perl@profvince.com',
+ url => 'http://www.profvince.com',
+ unload => sub { undef %opers; };
+
+1;
--- /dev/null
+package Xchat::VPIT::Services;
+
+use strict;
+use warnings;
+
+use Xchat qw/:all/;
+
+use lib get_info 'xchatdir';
+use Xchat::XPI;
+
+our $VERSION = '0.03';
+
+my $ph;
+
+sub get_servers_ctxt {
+ my %s;
+ return map $_->{context},
+ grep !$s{$_->{server}}++,
+ sort { $a->{type} <=> $b->{type} }
+ get_list 'channels';
+}
+
+hook_command 'ID', sub {
+ return EAT_PLUGIN if $_[0][1];
+ my $passwd = get_info 'nickserv';
+ return EAT_ALL unless $passwd;
+ command 'ID ' . $passwd;
+ return EAT_ALL;
+}, {
+ help_text => 'ID [password], identify you to NickServ'
+};
+
+hook_command 'AID', sub {
+ my $forcepasswd = $_[0][1];
+ my $oldctxt = get_context;
+ my @contexts = get_servers_ctxt;
+ for (@contexts) {
+ set_context $_;
+ my $passwd = $forcepasswd || get_info 'nickserv';
+ next unless $passwd;
+ command 'ID ' . $passwd;
+ }
+ set_context $oldctxt;
+ return EAT_ALL;
+}, {
+ help_text => 'AID [password], identify you on all servers'
+};
+
+hook_command 'GHOST', sub {
+ return EAT_PLUGIN if $_[0][2];
+ my $target = $_[0][1] || get_prefs 'irc_nick1';
+ my $passwd = get_info 'nickserv';
+ return EAT_ALL unless $target && $passwd;
+ if (nickcmp(get_info('nick'), $target)) {
+ command join ' ', 'GHOST', $target, $passwd;
+ }
+ return EAT_ALL;
+}, {
+ help_text => 'GHOST [nick] [password], kill the client currently connected with your nickname'
+};
+
+hook_command 'AGHOST', sub {
+ my $target = $_[0][1] || get_prefs 'irc_nick1';
+ return EAT_ALL unless $target;
+ my $forcepasswd = $_[0][2];
+ my $oldctxt = get_context;
+ my @contexts = get_servers_ctxt;
+ for (@contexts) {
+ set_context $_;
+ my $passwd = $forcepasswd || get_info 'nickserv';
+ next unless $passwd;
+ if (nickcmp(get_info('nick'), $target)) {
+ command join ' ', 'GHOST', $target, $passwd;
+ }
+ }
+ set_context $oldctxt;
+ return EAT_ALL;
+}, {
+ help_text => 'AGHOST [nick] [password], kill usurping clients on all servers'
+};
+
+sub csmode {
+ my $cmd = join ' ', 'QUOTE CHANSERV', $_[2], get_info('channel');
+ my @targets = @{$_[0]};
+ shift @targets;
+ @targets = (get_info 'nick') unless @targets;
+ command join ' ', $cmd, $_ for @targets;
+ return EAT_ALL;
+}
+
+hook_command "C$_", \&csmode, {
+ data => $_,
+ help_text => join ' ', $_, '[nicks] ,', (lc $_),
+ 'the specified targets (or you if none) on the current channel via ChanServ'
+} for map { $_, "DE$_" } qw/VOICE HALFOP OP PROTECT/;
+
+$ph = new Xchat::XPI name => 'IRC Services',
+ tag => 'Services',
+ desc => 'Various IRC services helpers',
+ author => 'Vincent Pit (VPIT)',
+ email => 'perl@profvince.com',
+ url => 'http://www.profvince.com';
+
+1;
--- /dev/null
+package Xchat::VPIT::Tools;
+
+use strict;
+use warnings;
+
+use Data::Dumper;
+use Encode qw/encode/;
+
+use Xchat qw/:all/;
+
+use lib get_info 'xchatdir';
+use Xchat::XPI;
+
+our $VERSION = '0.04';
+
+my $ph;
+
+BEGIN {
+ $Data::Dumper::Indent = 1;
+ $Data::Dumper::Sortkeys = 1;
+}
+
+hook_command 'TC', sub {
+ my $oldctxt = get_context;
+ for (get_list 'channels') {
+ set_context $_->{context};
+ command 'GUI COLOR 0';
+ }
+ set_context $oldctxt;
+ return EAT_ALL;
+}, {
+ help_text => 'TC, reset all tab color indicators'
+};
+
+sub d { return Dumper @_; }
+sub dp { print $ph Dumper(@_), "\n" }
+
+sub warneval { print $ph 'Warning: ' . (join ' ', @ _) }
+
+hook_command 'PERL', sub {
+ return EAT_ALL unless defined $_[0][1];
+ if ($_[0][1] eq '-o') {
+ return EAT_ALL unless defined $_[1][2];
+ local $SIG{__WARN__} = \&warneval;
+ my @result = grep defined, (eval $_[1][2]);
+ local $SIG{__WARN__} = 'DEFAULT';
+ if ($@) {
+ chomp $@;
+ print $ph "Error: $@\n";
+ } elsif (@result) {
+ command join ' ', 'MSG', get_info('channel'), @result;
+ } else {
+ print $ph "No output\n";
+ }
+ } else {
+ local $SIG{__WARN__} = \&warneval;
+ my @result = eval $_[1][1];
+ local $SIG{__WARN__} = 'DEFAULT';
+ if ($@) {
+ chomp $@;
+ print $ph "Error: $@\n";
+ return EAT_ALL;
+ }
+ @result = ('(empty)') unless @result;
+ my ($c, @scalars) = (0);
+ my @refs = grep {
+ (defined || (push @scalars, '(undef)') && 0)
+ && (ref || (push @scalars, $_) && 0)
+ && ((push @scalars, '$REF' . ++$c) || 1)
+ } @result;
+ {
+ local $Data::Dumper::Varname = 'REF';
+ print $ph 'Return: ', (join ' | ', @scalars), "\n", d @refs;
+ }
+ }
+ return EAT_ALL;
+}, {
+ help_text => 'PERL [-o] <perlexp>, evalute the expression with Perl'
+};
+
+hook_command 'URIESCAPE', sub {
+ return EAT_ALL unless defined $_[0][1];
+ my ($uri, $out, $protect);
+ if ($_[0][1] eq '-o') {
+ $uri = $_[1][2];
+ $out = 1;
+ } elsif ($_[0][1] eq '-p') {
+ $uri = $_[1][2];
+ $protect = 1;
+ } else {
+ $uri = $_[1][1];
+ }
+ $uri = encode get_info('charset'), $uri;
+ $uri =~ s/([^A-Za-z0-9\-_.!~*'():\/])/sprintf("%%%02X",ord($1))/ge;
+ if ($out) {
+ command 'SAY ' . $uri;
+ } else {
+ $uri =~ s/%/%%/g if $protect;
+ print $ph $uri, "\n";
+ }
+ return EAT_ALL;
+}, {
+ help_text => 'URIESCAPE [-o|-p] <uri>, escape unsafe characters in the URI'
+};
+
+hook_command 'WIDE', sub {
+ my $txt = $_[1][1];
+ return EAT_ALL unless defined $txt;
+ $txt =~ s/([\x21-\x7e])/chr 0xfee0 + ord $1/ge;
+ command 'SAY ' . $txt;
+ return EAT_ALL;
+}, {
+ help_text => 'WIDE <text>, say text in wide unicode characters'
+};
+
+$ph = new Xchat::XPI name => 'Misc tools',
+ tag => 'Tools',
+ desc => 'Perl interpretor, URI escaper',
+ author => 'Vincent Pit (VPIT)',
+ email => 'perl@profvince.com',
+ url => 'http://www.profvince.com';
+
+1;
projects / perl / scripts / xchat.git / commitdiff