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