/usr/share/perl5/POE/Component/IRC/Plugin/CTCP.pm is in libpoe-component-irc-perl 6.88+dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 | package POE::Component::IRC::Plugin::CTCP;
BEGIN {
$POE::Component::IRC::Plugin::CTCP::AUTHORITY = 'cpan:HINRIK';
}
$POE::Component::IRC::Plugin::CTCP::VERSION = '6.88';
use strict;
use warnings FATAL => 'all';
use Carp;
use POE::Component::IRC;
use POE::Component::IRC::Plugin qw( :ALL );
use POSIX qw(strftime);
sub new {
my ($package) = shift;
croak "$package requires an even number of arguments" if @_ & 1;
my %args = @_;
$args{ lc $_ } = delete $args{ $_ } for keys %args;
$args{eat} = 1 if !defined ( $args{eat} ) || $args{eat} eq '0';
return bless \%args, $package;
}
sub PCI_register {
my ($self,$irc) = splice @_, 0, 2;
$self->{irc} = $irc;
$irc->plugin_register( $self, 'SERVER', qw(ctcp_version ctcp_clientinfo ctcp_userinfo ctcp_time ctcp_ping ctcp_source) );
return 1;
}
sub PCI_unregister {
delete $_[0]->{irc};
return 1;
}
## no critic (TestingAndDebugging::ProhibitNoStrict)
sub S_ctcp_version {
my ($self, $irc) = splice @_, 0, 2;
my $nick = ( split /!/, ${ $_[0] } )[0];
my $our_version;
{
no strict 'vars';
if (defined $POE::Component::IRC::VERSION
&& $POE::Component::IRC::VERSION ne '1, set by base.pm') {
$our_version = 'dev-git';
}
else {
$our_version = $POE::Component::IRC::VERSION;
}
}
$irc->yield( ctcpreply => $nick => 'VERSION ' . ( defined $self->{version}
? $self->{version}
: "POE::Component::IRC-$our_version"
));
return PCI_EAT_CLIENT if $self->eat();
return PCI_EAT_NONE;
}
sub S_ctcp_time {
my ($self, $irc) = splice @_, 0, 2;
my $nick = ( split /!/, ${ $_[0] } )[0];
$irc->yield(ctcpreply => $nick => strftime('TIME %a, %d %b %Y %H:%M:%S %z', localtime));
return PCI_EAT_CLIENT if $self->eat();
return PCI_EAT_NONE;
}
sub S_ctcp_ping {
my ($self,$irc) = splice @_, 0, 2;
my $nick = ( split /!/, ${ $_[0] } )[0];
my $timestamp = ${ $_[2] };
$irc->yield( ctcpreply => $nick => 'PING ' . $timestamp );
return PCI_EAT_CLIENT if $self->eat();
return PCI_EAT_NONE;
}
sub S_ctcp_clientinfo {
my ($self, $irc) = splice @_, 0, 2;
my $nick = ( split /!/, ${ $_[0] } )[0];
$irc->yield(ctcpreply => $nick => 'CLIENTINFO ' . ($self->{clientinfo}
? $self->{clientinfo}
: 'http://search.cpan.org/perldoc?POE::Component::IRC::Plugin::CTCP'
));
return PCI_EAT_CLIENT if $self->eat();
return PCI_EAT_NONE;
}
sub S_ctcp_userinfo {
my ($self, $irc) = splice @_, 0, 2;
my $nick = ( split /!/, ${ $_[0] } )[0];
$irc->yield( ctcpreply => $nick => 'USERINFO ' . ( $self->{userinfo} ? $self->{userinfo} : 'm33p' ) );
return PCI_EAT_CLIENT if $self->eat();
return PCI_EAT_NONE;
}
sub S_ctcp_source {
my ($self, $irc) = splice @_, 0, 2;
my $nick = ( split /!/, ${ $_[0] } )[0];
$irc->yield( ctcpreply => $nick => 'SOURCE ' . ($self->{source}
? $self->{source}
: 'http://search.cpan.org/dist/POE-Component-IRC'
));
return PCI_EAT_CLIENT if $self->eat();
return PCI_EAT_NONE;
}
sub eat {
my $self = shift;
my $value = shift;
return $self->{eat} if !defined $value;
return $self->{eat} = $value;
}
1;
=encoding utf8
=head1 NAME
POE::Component::IRC::Plugin::CTCP - A PoCo-IRC plugin that auto-responds to CTCP requests
=head1 SYNOPSIS
use strict;
use warnings;
use POE qw(Component::IRC Component::IRC::Plugin::CTCP);
my $nickname = 'Flibble' . $$;
my $ircname = 'Flibble the Sailor Bot';
my $ircserver = 'irc.blahblahblah.irc';
my $port = 6667;
my $irc = POE::Component::IRC->spawn(
nick => $nickname,
server => $ircserver,
port => $port,
ircname => $ircname,
) or die "Oh noooo! $!";
POE::Session->create(
package_states => [
main => [ qw(_start) ],
],
);
$poe_kernel->run();
sub _start {
# Create and load our CTCP plugin
$irc->plugin_add( 'CTCP' => POE::Component::IRC::Plugin::CTCP->new(
version => $ircname,
userinfo => $ircname,
));
$irc->yield( register => 'all' );
$irc->yield( connect => { } );
return:
}
=head1 DESCRIPTION
POE::Component::IRC::Plugin::CTCP is a L<POE::Component::IRC|POE::Component::IRC>
plugin. It watches for C<irc_ctcp_version>, C<irc_ctcp_userinfo>,
C<irc_ctcp_ping>, C<irc_ctcp_time> and C<irc_ctcp_source> events and
autoresponds on your behalf.
=head1 METHODS
=head2 C<new>
Takes a number of optional arguments:
B<'version'>, a string to send in response to C<irc_ctcp_version>. Default is
PoCo-IRC and version;
B<'clientinfo'>, a string to send in response to C<irc_ctcp_clientinfo>.
Default is L<http://search.cpan.org/perldoc?POE::Component::IRC::Plugin::CTCP>.
B<'userinfo'>, a string to send in response to C<irc_ctcp_userinfo>. Default
is 'm33p';
B<'source'>, a string to send in response to C<irc_ctcp_source>. Default is
L<http://search.cpan.org/dist/POE-Component-IRC>.
B<'eat'>, by default the plugin uses PCI_EAT_CLIENT, set this to 0 to disable
this behaviour;
Returns a plugin object suitable for feeding to
L<POE::Component::IRC|POE::Component::IRC>'s C<plugin_add> method.
=head2 C<eat>
With no arguments, returns true or false on whether the plugin is "eating" CTCP
events that it has dealt with. An argument will set "eating" to on or off
appropriately, depending on whether the value is true or false.
=head1 AUTHOR
Chris 'BinGOs' Williams
=head1 SEE ALSO
CTCP Specification L<http://www.irchelp.org/irchelp/rfc/ctcpspec.html>.
=cut
|