File Coverage

blib/lib/POE/Component/Server/Twirc.pm
Criterion Covered Total %
statement 54 599 9.0
branch 0 208 0.0
condition 0 59 0.0
subroutine 18 112 16.0
pod 0 26 0.0
total 72 1004 7.1


line stmt bran cond sub pod time code
1             package POE::Component::Server::Twirc;
2              
3 2     2   15452 use MooseX::POE;
  2         302435  
  2         8  
4              
5 2     2   471769 use utf8;
  2         15  
  2         8  
6 2     2   1359 use Log::Log4perl qw/:easy/;
  2         58997  
  2         8  
7 2     2   756 use POE qw(Component::Server::IRC);
  2         2  
  2         15  
8 2     2   162677 use Net::OAuth;
  2         881  
  2         45  
9 2     2   902 use Digest::SHA;
  2         4722  
  2         86  
10 2     2   710 use String::Truncate elide => { marker => '…' };
  2         5527  
  2         11  
11 2     2   923 use POE::Component::Server::Twirc::LogAppender;
  2         4  
  2         39  
12 2     2   596 use POE::Component::Server::Twirc::State;
  2         4  
  2         100  
13 2     2   16 use Encode qw/decode/;
  2         2  
  2         102  
14 2     2   8 use Try::Tiny;
  2         2  
  2         87  
15 2     2   8 use Scalar::Util qw/reftype weaken/;
  2         3  
  2         79  
16 2     2   1918 use AnyEvent;
  2         7219  
  2         53  
17 2     2   885 use AnyEvent::Twitter;
  2         112722  
  2         53  
18 2     2   834 use AnyEvent::Twitter::Stream;
  2         12724  
  2         62  
19 2     2   848 use HTML::Entities;
  2         21668  
  2         233  
20 2     2   1194 use Regexp::Common qw/URI/;
  2         4375  
  2         9  
21 2     2   36381 use JSON::MaybeXS;
  2         3  
  2         15268  
22              
23             with 'MooseX::Log::Log4perl';
24              
25             =head1 NAME
26              
27             POE::Component::Server::Twirc - Twitter/IRC gateway
28              
29             =head1 SYNOPSIS
30              
31             use POE::Component::Server::Twirc;
32              
33             POE::Component::Server::Twirc->new;
34              
35             POE::Kernel->run;
36              
37             =head1 DESCRIPTION
38              
39             C<POE::Component::Server::Twirc> provides an IRC/Twitter gateway. Twitter
40             friends are added to a channel and messages they post on twitter appear as
41             channel messages in IRC. The IRC interface supports several Twitter features,
42             including posting status updates, following and un-following Twitter feeds,
43             enabling and disabling mobile device notifications or retweets, sending direct
44             messages, and querying information about specific Twitter users.
45              
46             Friends who are also followers are given "voice" as a visual clue in IRC.
47              
48             =head1 METHODS
49              
50             =head2 new
51              
52             Spawns a POE component encapsulating the Twitter/IRC gateway.
53              
54             Arguments:
55              
56             =over 4
57              
58              
59             =item irc_server_name
60              
61             (Optional) The name of the IRC server. Defaults to C<twitter.irc>.
62              
63             =cut
64              
65             has irc_server_name => isa => 'Str', is => 'ro', default => 'twitter.irc';
66              
67             =item irc_server_port
68              
69             (Optional) The port number the IRC server binds to. Defaults to 6667.
70              
71             =cut
72              
73             has irc_server_port => isa => 'Int', is => 'ro', default => 6667;
74              
75             =item irc_server_bindaddr
76              
77             (Optional) The local address to bind to. Defaults to '127.0.0.1'.
78              
79             =cut
80              
81             # will be defaulted to INADDR_ANY by POE::Wheel::SocketFactory
82             has irc_server_bindaddr => isa => 'Str', is => 'ro', default => '127.0.0.1';
83              
84             =item irc_mask
85              
86             (Optional) The IRC user/host mask used to restrict connecting users. Defaults to C<*@127.0.0.1>.
87              
88             =cut
89              
90             has irc_mask => isa => 'Str', is => 'ro', default => '*@127.0.0.1';
91              
92              
93             =item irc_password
94              
95             (Optional) Password used to authenticate to the IRC server.
96              
97             =cut
98              
99             has irc_password => isa => 'Str', is => 'ro';
100              
101              
102             =item irc_botname
103              
104             (Optional) The name of the channel operator bot. Defaults to C<tweeter>. Select a name
105             that does not conflict with friends, followers, or your own IRC nick.
106              
107             =cut
108              
109             has irc_botname => isa => 'Str', is => 'ro', default => 'tweeter';
110              
111              
112             =item irc_botircname
113              
114             (Optional) Text to be used as the channel operator bot's IRC full name.
115              
116             =cut
117              
118             has irc_botircname => isa => 'Str', is => 'ro', default => 'Your friendly Twitter agent';
119              
120              
121             =item irc_channel
122              
123             (Optional) The name of the channel to use. Defaults to C<&twitter>.
124              
125             =cut
126              
127             has irc_channel => isa => 'Str', is => 'ro', default => '&twitter';
128              
129             =item selection_count
130              
131             (Optional) How many favorites candidates to display for selection. Defaults to 3.
132              
133             =cut
134              
135             has selection_count => isa => 'Int', is => 'ro', default => 3;
136              
137             =item truncate_to
138              
139             (Optional) When displaying tweets for selection, they will be truncated to this length.
140             Defaults to 60.
141              
142             =cut
143              
144             has truncate_to => isa => 'Int', is => 'ro', default => 60;
145              
146              
147             =item log_channel
148              
149             (Optional) If specified, twirc will post log messages to this channel.
150              
151             =cut
152              
153             has log_channel => isa => 'Str', is => 'ro';
154              
155             =item state_file
156              
157             (Optional) File used to store state information between sessions, including last message read for
158             replies, direct messages, and timelines.
159              
160             =cut
161              
162             has state_file => isa => 'Str', is => 'ro';
163              
164             =item plugins
165              
166             (Optional) An array of plugin objects.
167              
168             =cut
169              
170             has plugins => isa => 'ArrayRef[Object]', is => 'ro', default => sub { [] };
171              
172             =back
173              
174              
175             =cut
176              
177             has irc_nickname => isa => 'Str', is => 'rw', init_arg => undef;
178              
179             has ircd => (
180             isa => 'POE::Component::Server::IRC',
181             is => 'rw',
182             weak_ref => 1,
183             handles => {
184             add_auth => 'add_auth',
185             is_channel_member => 'state_is_chan_member',
186             nick_exists => 'state_nick_exists',
187             post_ircd => 'yield',
188             user_route => '_state_user_route',
189             },
190             );
191              
192             has _users_by_nick =>
193             traits => [qw/Hash/],
194             isa => 'HashRef[HashRef|Object]',
195             is => 'rw',
196             init_arg => undef,
197             lazy => 1,
198             default => sub { +{ map { lc($$_{screen_name}) => $_ } shift->get_users } },
199             handles => {
200             set_user => 'set',
201             get_user_by_nick => 'get',
202             delete_user => 'delete',
203             user_nicks => 'keys',
204             };
205              
206             around set_user => sub {
207             my ( $orig, $self, $user ) = @_;
208              
209             $self->set_user_by_id($user->{id}, $user);
210             $self->$orig(lc $user->{screen_name}, $user);
211             };
212              
213             around get_user_by_nick => sub {
214             my ( $orig, $self, $nick ) = @_;
215              
216             $self->$orig(lc $nick);
217             };
218              
219             around delete_user => sub {
220             my ( $orig, $self, $user ) = @_;
221              
222             $self->delete_user_by_id($user->{id});
223             $self->$orig(lc $user->{screen_name});
224             };
225              
226             has has_joined_channel => (
227             init_arg => undef,
228             is => 'ro',
229             traits => [ qw/Bool/ ],
230             default => 0,
231             handles => {
232             joined_channel => 'set',
233             left_channel => 'unset',
234             },
235             );
236              
237             has stash => (
238             init_arg => undef,
239             isa => 'HashRef',
240             traits => [ qw/Hash/ ],
241             is => 'rw',
242             predicate => 'has_stash',
243             clearer => 'clear_stash',
244             handles => {
245             stashed_candidates => [ get => 'candidates' ],
246             stashed_handler => [ get => 'handler' ],
247             stashed_message => [ get => 'message' ],
248             delete_stashed_handler => [ delete => 'handler' ],
249             },
250             );
251              
252             around stashed_candidates => sub {
253             my ( $orig, $self ) = @_;
254              
255             return @{ $self->$orig || [] };
256             };
257              
258             has state => (
259             isa => 'POE::Component::Server::Twirc::State',
260             is => 'rw',
261             lazy => 1,
262             default => sub { POE::Component::Server::Twirc::State->new },
263             handles => [qw/
264             access_token
265             access_token_secret
266             delete_user_by_id
267             followers
268             add_follower_id
269             remove_follower_id
270             is_follower_id
271             followers_updated_at
272             get_user_by_id
273             get_users
274             set_user_by_id
275             store
276             /],
277             );
278              
279             has client_encoding => isa => 'Str', is => 'rw', default => sub { 'utf-8' };
280              
281             has reconnect_delay => is => 'rw', isa => 'Num', default => 0;
282             has twitter_stream_watcher => (
283             is => 'rw',
284             clearer => 'disconnect_twitter_stream',
285             predicate => 'has_twitter_stream_watcher',
286             );
287              
288             has authenticated_user => (
289             is => 'rw',
290             isa => 'HashRef',
291             traits => [ qw/Hash/ ],
292             init_arg => undef,
293             handles => {
294             twitter_screen_name => [ get => 'screen_name' ],
295             twitter_id => [ get => 'id' ],
296             },
297             );
298              
299             has is_shutting_down => (
300             is => 'ro',
301             traits => [ qw/Bool/ ],
302             default => 0,
303             handles => {
304             shutting_down => 'set',
305             },
306             );
307              
308             has twitter_rest_api => (
309             is => 'ro',
310             lazy => 1,
311             default => sub {
312             my $self = shift;
313              
314             AnyEvent::Twitter->new(
315             $self->_twitter_auth,
316             token => $self->access_token,
317             token_secret => $self->access_token_secret,
318             );
319             },
320             handles => {
321             twitter_rest_api_request => 'request',
322             },
323             );
324              
325 0     0 0   sub to_json { JSON::MaybeXS->new->encode($_[1]) }
326 0     0 0   sub to_pretty_json { JSON::MaybeXS->new->pretty>encode($_[1]) }
327              
328             # force build of users by nick hash early
329 0     0 0   sub BUILD { shift->_users_by_nick }
330              
331             event get_authenticated_user => sub {
332 0     0     my $self = $_[OBJECT];
333              
334 0           $self->twitter(verify_credentials => { include_entities => 1 },
335             $_[SESSION]->callback('get_authenticated_user_response')
336             );
337             };
338              
339             event get_authenticated_user_response => sub {
340 0     0     my $self = $_[OBJECT];
341 0           my ( $r ) = @{ $_[ARG1] };
  0            
342              
343 0 0         if ( $r ) {
344 0           $self->authenticated_user($r);
345 0 0         if ( my $status = delete $$r{status} ) {
346 0           $$status{user} = $r;
347 0           $self->set_topic($self->formatted_status_text($status));
348             }
349 0           $self->yield('connect_twitter_stream');
350             }
351             else {
352 0           FATAL("Failed to get authenticated user data from twitter (verify_credentials)");
353 0           $self->yield('poco_shutdown');
354             }
355             };
356              
357             my %endpoint_for = (
358             add_list_member => [ post => 'lists/members/create' ],
359             create_block => [ post => 'blocks/create' ],
360             create_favorite => [ post => 'favorites/create' ],
361             create_friend => [ post => 'friendships/create' ],
362             destroy_block => [ post => 'blocks/destroy' ],
363             destroy_friend => [ post => 'friendships/destroy' ],
364             followers_ids => [ get => 'followers/ids' ],
365             lookup_users => [ get => 'users/lookup' ],
366             new_direct_message => [ post => 'direct_messages/new' ],
367             rate_limit_status => [ get => 'application/rate_limit_status' ],
368             remove_list_member => [ post => 'lists/members/destroy' ],
369             report_spam => [ post => 'users/report_spam' ],
370             retweet => [ post => 'statuses/retweet/:id' ],
371             show_friendship => [ get => 'friendships/show' ],
372             show_user => [ get => 'users/show' ],
373             update => [ post => 'statuses/update' ],
374             update_friendship => [ post => 'friendships/update' ],
375             user_timeline => [ get => 'statuses/user_timeline' ],
376             verify_credentials => [ get => 'account/verify_credentials' ],
377             );
378              
379             sub twitter {
380 0 0 0 0 0   my $cb = ref $_[-1] && reftype $_[-1] eq 'CODE' ? pop : sub {};
  0     0      
381 0           my ( $self, $method, $args ) = @_;
382 0           weaken $self;
383              
384 0 0         my ( $http_method, $endpoint ) = @{ $endpoint_for{$method} || [] }
  0 0          
385             or return ERROR("no endopoint defined for $method");
386              
387             # Flatten array args into comma delimited strings
388 0           for my $k ( keys %$args ) {
389 0 0         $args->{$k} = join ',' => @{ $args->{$k} } if ref $args->{$k} eq ref [];
  0            
390             }
391              
392             # handle path parameters
393 0           $endpoint =~ s/:(\w+)$/delete $$args{$1}/e;
  0            
394              
395 0           DEBUG(qq/Twitter API call: $http_method $endpoint ${ \join ', ' => map { "$_ => '$$args{$_}'" } keys %$args }/);
  0            
  0            
396              
397 0           my $w; $w = $self->twitter_rest_api_request(
398             method => $http_method,
399             api => $endpoint,
400             params => $args,
401             sub {
402 0     0     my ( $header, $r, $reason, $http_response ) = @_;
403              
404 0           undef $w;
405 0 0         if ( $r ) {
406 0           $cb->($r);
407             }
408             else {
409 0           $self->twitter_error(qq/$$header{Status}: $reason => ${ \join ', ' => map { "$$_{code}: $$_{message}" } @{ $http_response->{errors} } }/);
  0            
  0            
  0            
410             }
411             }
412 0           );
413             }
414              
415             sub bot_says {
416 0     0 0   my ($self, $channel, $text) = @_;
417              
418 0           $self->post_ircd('daemon_cmd_privmsg', $self->irc_botname, $channel, $text);
419             };
420              
421             sub bot_notice {
422 0     0 0   my ($self, $channel, $text) = @_;
423              
424 0           $self->post_ircd(daemon_cmd_notice => $self->irc_botname, $channel, $text);
425             }
426              
427              
428             sub twitter_error {
429 0     0 0   my ($self, $text) = @_;
430              
431 0           $self->bot_notice($self->irc_channel, "Twitter error: $text");
432             };
433              
434             # set topic from status, iff newest status
435             sub set_topic {
436 0     0 0   my ($self, $text) = @_;
437              
438 0           $self->post_ircd(daemon_cmd_topic => $self->irc_botname, $self->irc_channel, $text);
439             };
440              
441             # match any nick
442             sub nicks_alternation {
443 0     0 0   my $self = shift;
444              
445 0           return join '|', map quotemeta, $self->user_nicks;
446             }
447              
448             sub add_user {
449 0     0 0   my ($self, $user) = @_;
450              
451 0           my $nick = $$user{screen_name};
452 0           TRACE("add_user: $nick");
453              
454             # handle nick changes
455 0 0         if ( my $current_user = $self->get_user_by_id($$user{id}) ) {
456 0 0         $self->post_ircd(daemon_cmd_nick => $$current_user{screen_name}, $nick)
457             if $nick ne $$current_user{screen_name};
458             }
459              
460 0           $$user{FRESH} = time;
461 0           $self->set_user($user);
462              
463 0 0         unless ( $self->nick_exists($nick) ) {
464 0           $self->post_ircd(add_spoofed_nick => { nick => $nick, ircname => $$user{name} });
465             }
466             }
467              
468             sub _twitter_auth {
469             # ROT13: Gjvggre qbrf abg jnag pbafhzre xrl/frperg vapyhqrq va bcra
470             # fbhepr nccf. Gurl frrz gb guvax cebcevrgnel pbqr vf fnsre orpnhfr
471             # gur pbafhzre perqragvnyf ner boshfpngrq. Fb, jr'yy boshfpngr gurz
472             # urer jvgu ebg13 naq jr'yy or "frpher" whfg yvxr n cebcevrgnel ncc.
473 0     0     ( grep tr/a-zA-Z/n-za-mN-ZA-M/, map $_,
474             pbafhzre_xrl => 'ntqifMSFhMC0NdSWmBWgtN',
475             pbafhzre_frperg => 'CDDA2pAiDcjb6saxt0LLwezCBV97VPYGAF0LMa0oH',
476             ),
477             }
478              
479             sub max_reconnect_delay () { 600 } # ten minutes
480             sub twitter_stream_timeout () { 65 } # should get activity every 30 seconds
481             sub friends_stale_after () { 7*24*3600 } # 1 week
482              
483             sub is_user_stale {
484 0     0 0   my ( $self, $user ) = @_;
485              
486 0           return time - $user->{FRESH} > $self->friends_stale_after;
487             }
488              
489             sub followers_stale_after () { 24*3600 } # 1 day
490             sub are_followers_stale {
491 0     0 0   my $self = shift;
492              
493 0           return time - $self->followers_updated_at > $self->followers_stale_after;
494             }
495              
496             sub formatted_status_text {
497 0     0 0   my ( $self, $status ) = @_;
498              
499 0           my $is_retweet = !!$$status{retweeted_status};
500 0   0       my $s = $$status{retweeted_status} || $status;
501 0           my $text = $$s{text};
502 0 0         for my $e ( reverse @{$$s{entities}{urls} || []} ) {
  0            
503 0           my ($start, $end) = @{$$e{indices}};
  0            
504 0           substr $text, $start, $end - $start, "[$$e{display_url}]($$e{url})";
505             }
506              
507 0           decode_entities($text);
508              
509             # When the status is a retweet from verify_credentials, it doesn't have a user element
510 0   0       my $orig_author = $$s{user}{screen_name} || $$status{entities}{user_mentions}[0]{screen_name};
511 0 0         $text = "RT \@$orig_author: $text" if $is_retweet;
512              
513 0           return $text;
514             }
515              
516             event connect_twitter_stream => sub {
517 0     0     weaken(my $self = $_[OBJECT]);
518              
519 0           TRACE('connect_twitter_stream');
520              
521             my $w = AnyEvent::Twitter::Stream->new(
522             $self->_twitter_auth,
523             token => $self->access_token,
524             token_secret => $self->access_token_secret,
525             method => 'userstream',
526             timeout => $self->twitter_stream_timeout,
527             on_connect => sub {
528 0     0     INFO('Connected to Twitter');
529 0           $self->bot_notice($self->irc_channel, "Twitter stream connected");
530 0           $self->reconnect_delay(0);
531             },
532             on_eof => sub {
533 0     0     $self->disconnect_twitter_stream;
534 0           TRACE("on_eof");
535 0           $self->bot_notice($self->irc_channel, "Twitter stream disconnected");
536 0 0         $self->yield('connect_twitter_stream') unless $self->is_shutting_down;
537             },
538             on_error => sub {
539 0     0     my $e = shift;
540              
541 0           ERROR("on_error: $e");
542 0           $self->bot_notice($self->irc_channel, "Twitter stream error: $e");
543 0 0         if ( $e =~ /^420:/ ) {
544 0           FATAL("excessive login rate; shutting down");
545 0           $self->yield('poco_shutdown');
546 0           return;
547             }
548              
549 0           $self->disconnect_twitter_stream;
550              
551             # progressively backoff on reconnection attepts to max_reconnect_delay
552 0 0         if ( my $delay = $self->reconnect_delay ) {
553 0           DEBUG("delaying $delay seconds before reconnecting");
554             }
555 0           my $t; $t = AE::timer $self->reconnect_delay, 0, sub {
556 0           undef $t;
557 0   0       my $next_delay = $self->reconnect_delay * 2 || 1;
558 0 0         $next_delay = $self->max_reconnect_delay if $next_delay > $self->max_reconnect_delay;
559 0           $self->reconnect_delay($next_delay);
560 0           $self->yield('connect_twitter_stream');
561 0           };
562             },
563             on_keepalive => sub {
564 0     0     TRACE("on_keepalive");
565             },
566             on_friends => sub {
567 0     0     TRACE("on_friends: ", $self->to_json(@_));
568 0           $self->yield(friends_ids => shift);
569             },
570             on_event => sub {
571 0     0     my $msg = shift;
572              
573 0           TRACE("on_event: $$msg{event}");
574 0           $self->yield(on_event => $msg);
575             },
576             on_tweet => sub {
577 0     0     my $msg = shift;
578              
579 0           TRACE("on_tweet");
580              
581 0 0         return unless $self->has_joined_channel;
582              
583 0 0         if ( exists $$msg{sender} ) {
    0          
    0          
    0          
    0          
584 0           DEBUG('received old style direct_message');
585 0           $self->yield(on_direct_message => $msg);
586             }
587             elsif ( exists $$msg{text} ) {
588 0           $self->yield(on_tweet => $msg);
589             }
590             elsif ( exists $$msg{direct_message} ) {
591 0           $self->yield(on_direct_message => $$msg{direct_message});
592             }
593             elsif ( exists $$msg{limit} ) {
594 0           WARN("track limit: $$msg{limit}{track}");
595 0           $self->bot_notice($self->irc_channel,
596             "Track limit received - $$msg{limit}{track} statuses missed.");
597             }
598             elsif ( exists $$msg{scrub_geo} ) {
599             # $$msg{scrub_geo} = {"user_id":14090452,"user_id_str":"14090452","up_to_status_id":23260136625,"up_to_status_id_str":"23260136625"}
600 0           my $e = $$msg{scrub_geo};
601 0           INFO("scrub_geo: user_id=$$e{user_id}, up_to_status_id=$$e{up_to_status_id}");
602             }
603             else {
604 0           ERROR("unexpected message: ", $self->to_pretty_json($msg));
605 0           $self->bot_notice($self->irc_channel, "Unexpected twitter packet, see the log for details");
606             }
607             },
608             on_delete => sub {
609 0     0     TRACE("on_delete");
610             },
611 0           );
612              
613 0           $self->twitter_stream_watcher($w);
614             };
615              
616             sub START {
617 0     0 0   weaken(my $self = $_[OBJECT]);
618              
619             $self->ircd(
620             POE::Component::Server::IRC->spawn(
621             config => {
622             servername => $self->irc_server_name,
623             nicklen => 15,
624             network => 'SimpleNET'
625             },
626             inline_states => {
627 0     0     _stop => sub { TRACE('[ircd:stop]') },
628             },
629             )
630 0           );
631              
632             # register ircd to receive events
633 0           $self->post_ircd('register' );
634 0           $self->add_auth(
635             mask => $self->irc_mask,
636             password => $self->irc_password,
637             no_tilde => 1,
638             );
639 0           $self->post_ircd('add_listener', port => $self->irc_server_port,
640             bindaddr => $self->irc_server_bindaddr);
641              
642             # add super user
643 0           $self->post_ircd(add_spoofed_nick => {
644             nick => $self->irc_botname,
645             ircname => $self->irc_botircname,
646             });
647 0           $self->post_ircd(daemon_cmd_join => $self->irc_botname, $self->irc_channel);
648              
649             # logging
650 0 0         if ( $self->log_channel ) {
651 0           $self->post_ircd(daemon_cmd_join => $self->irc_botname, $self->log_channel);
652 0           my $logger = Log::Log4perl->get_logger('');
653 0           my $appender = Log::Log4perl::Appender->new(
654             'POE::Component::Server::Twirc::LogAppender',
655             name => 'twirc-logger',
656             ircd => $self->ircd,
657             irc_botname => $self->irc_botname,
658             irc_channel => $self->log_channel,
659             );
660 0           $logger->add_appender($appender);
661             }
662              
663 0           POE::Kernel->sig(TERM => 'poco_shutdown');
664 0           POE::Kernel->sig(INT => 'poco_shutdown');
665              
666 0           $self->yield('get_authenticated_user');
667              
668 0           return $self;
669             }
670              
671             # Without detaching the ircd child session, the application will not
672             # shut down. Bug in PoCo::Server::IRC?
673             event _child => sub {
674 0     0     my ($self, $kernel, $event, $child) = @_[OBJECT, KERNEL, ARG0, ARG1];
675              
676 0           TRACE("[_child] $event $child");
677 0 0         $kernel->detach_child($child) if $event eq 'create';
678             };
679              
680             event poco_shutdown => sub {
681 0     0     my ($self) = @_;
682              
683 0           TRACE("[poco_shutdown]");
684 0           $self->shutting_down;
685 0           $self->disconnect_twitter_stream;
686 0           $_[KERNEL]->alarm_remove_all();
687 0           $self->post_ircd('unregister');
688 0           $self->post_ircd('shutdown');
689 0 0         if ( $self->state_file ) {
690 0     0     try { $self->store($self->state_file) }
691             catch {
692 0     0     s/ at .*//s;
693 0           ERROR($_);
694 0           $self->bot_notice($self->irc_channel, "Error storing state file: $_");
695 0           };
696             }
697              
698             # TODO: Why does twirc often fail to shut down?
699             # This is surely the WRONG thing to do, but hit the big red kill switch.
700 0           exit 0;
701             };
702              
703             ########################################################################
704             # IRC events
705             ########################################################################
706              
707             event ircd_daemon_nick => sub {
708 0     0     my ($self, $sender, $nick) = @_[OBJECT, SENDER, ARG0];
709              
710 0           TRACE("[ircd_daemon_nick] $nick");
711              
712             # if it's a nick change, we only get ARG0 and ARG1
713 0 0         return unless defined $_[ARG2];
714 0 0         return if $self->user_route($nick) eq 'spoofed';
715              
716 0           $self->irc_nickname($nick);
717              
718             # Abuse! Calling the private implementation of ircd to force-join the connecting
719             # user to the twitter channel. ircd set's it's heap to $self: see ircd's perldoc.
720 0           $sender->get_heap->_daemon_cmd_join($nick, $self->irc_channel);
721              
722             # Give the user half ops (just a visual cue)
723 0           $self->post_ircd(daemon_cmd_mode => $self->irc_botname, $self->irc_channel, '+h', $nick);
724             };
725              
726             event ircd_daemon_join => sub {
727 0     0     my($self, $sender, $user, $ch) = @_[OBJECT, SENDER, ARG0, ARG1];
728              
729 0           TRACE("[ircd_daemon_join] $user, $ch");
730 0 0         return unless my($nick) = $user =~ /^([^!]+)!/;
731 0 0         return if $self->user_route($nick) eq 'spoofed';
732              
733 0 0 0       if ( $ch eq $self->irc_channel ) {
    0          
734 0           $self->joined_channel;
735 0           TRACE(" joined!");
736 0           return;
737             }
738             elsif ( $self->log_channel && $ch eq $self->log_channel ) {
739 0           my $appender = Log::Log4perl->appender_by_name('twirc-logger');
740 0           $appender->dump_history;
741             }
742             else {
743 0           TRACE(" ** part **");
744             # only one channel allowed
745 0           $sender->get_heap()->_daemon_cmd_part($nick, $ch);
746             }
747             };
748              
749             event ircd_daemon_part => sub {
750 0     0     my($self, $user_name, $ch) = @_[OBJECT, ARG0, ARG1];
751              
752 0 0         return unless my($nick) = $user_name =~ /^([^!]+)!/;
753 0 0         return if $nick eq $self->irc_botname;
754              
755 0 0         if ( my $user = $self->get_user_by_nick($nick) ) {
756 0           $self->delete_user($user);
757             }
758              
759 0 0 0       $self->left_channel if $ch eq $self->irc_channel && $nick eq $self->irc_nickname;
760             };
761              
762             event ircd_daemon_quit => sub {
763 0     0     my($self, $user) = @_[OBJECT, ARG0];
764              
765 0           TRACE("[ircd_daemon_quit]");
766 0 0         return unless my($nick) = $user =~ /^([^!]+)!/;
767 0 0         return unless $nick eq $self->irc_nickname;
768              
769 0           $self->left_channel;
770 0           $self->yield('poco_shutdown');
771             };
772              
773             event ircd_daemon_public => sub {
774 0     0     my ($self, $user, $channel, $text) = @_[OBJECT, ARG0, ARG1, ARG2];
775              
776 0 0         return unless $channel eq $self->irc_channel;
777              
778 0           $text = decode($self->client_encoding, $text);
779              
780 0           $text =~ s/\s+$//;
781              
782 0           my $nick = ( $user =~ m/^(.*)!/)[0];
783              
784 0           TRACE("[ircd_daemon_public] $nick: $text");
785 0 0         return unless $nick eq $self->irc_nickname;
786              
787             # give any command handler a shot
788 0 0         if ( $self->has_stash ) {
789 0           DEBUG("stash exists...");
790 0           my $handler = $self->delete_stashed_handler;
791 0 0         if ( $handler ) {
792 0 0         return if $self->call($handler, $channel, $text); # handled
793 0           $self->clear_stash;
794             }
795             else {
796 0           ERROR("stash exists with no handler");
797             }
798             # the user ignored a command completion request, kill it
799 0           $self->clear_stash;
800             }
801              
802 0           for my $plugin ( @{$self->plugins} ) {
  0            
803 0 0 0       $plugin->preprocess($self, $channel, $nick, \$text) && last
804             if $plugin->can('preprocess');
805             }
806              
807             # treat "nick: ..." as "post @nick ..."
808 0           my $nick_alternation = $self->nicks_alternation;
809 0           $text =~ s/^(?:post\s+)?($nick_alternation):\s+/post \@$1 /i;
810              
811 0           my ($command, $argstr) = split /\s+/, $text, 2;
812 0 0         if ( $command =~ /^\w+$/ ) {
813 0           my $event = "cmd_$command";
814              
815             # Give each plugin a opportunity:
816             # - Plugins return true if they swallow the event; false to continue
817             # the processing chain.
818             # - Plugins can modify the text, so pass a ref.
819 0           for my $plugin ( @{$self->plugins} ) {
  0            
820 0 0 0       $plugin->$event($self, $channel, $nick, \$argstr) && return
821             if $plugin->can($event);
822             }
823 0 0         if ( $self->can($event) ) {
824 0           $self->yield($event, $channel, $argstr);
825             }
826             else {
827 0           $self->bot_says($channel, qq/I don't understand "$command". Try "help"./)
828             }
829             }
830             else {
831 0           $self->bot_says($channel, qq/That doesn't look like a command. Try "help"./);
832             }
833             };
834              
835             event ircd_daemon_privmsg => sub {
836 0     0     my ($self, $user, $target_nick, $text) = @_[OBJECT, ARG0..ARG2];
837              
838             # owning user is the only one allowed to send direct messages
839 0           my $me = $self->irc_nickname;
840 0 0         return unless $user =~ /^\Q$me\E!/;
841              
842 0           $text = decode($self->client_encoding, $text);
843              
844 0 0         unless ( $self->get_user_by_nick($target_nick) ) {
845             # TODO: handle the error the way IRC would?? (What channel?)
846 0           $self->bot_says($self->irc_channel, qq/You don't appear to be following $target_nick; message not sent./);
847 0           return;
848             }
849              
850 0           $self->twitter(new_direct_message => { screen_name => $target_nick, text => $text });
851             };
852              
853             event friend_join => sub {
854 0     0     my ( $self, $friend ) = @_[OBJECT, ARG0];
855              
856 0           my $nick = $$friend{screen_name};
857 0           TRACE("friend_join: $nick");
858              
859 0 0         $self->post_ircd(add_spoofed_nick => { nick => $nick, ircname => $$friend{name} })
860             unless $self->nick_exists($nick);
861              
862 0           $self->post_ircd(daemon_cmd_join => $nick, $self->irc_channel);
863 0 0         if ( $self->is_follower_id($$friend{id}) ) {
864 0           $self->post_ircd(daemon_cmd_mode => $self->irc_botname, $self->irc_channel, '+v', $nick);
865             }
866             };
867              
868             event lookup_friends => sub {
869 0     0     my ( $self, $session, $ids ) = @_[OBJECT, SESSION, ARG0];
870              
871 0 0         return unless @$ids;
872              
873 0           $self->twitter(lookup_users => { user_id => $ids },
874             $session->callback('lookup_friends_response')
875             );
876             };
877              
878             event lookup_friends_response => sub {
879 0     0     my $self = $_[OBJECT];
880 0           my ( $r ) = @{ $_[ARG1] };
  0            
881              
882 0 0         for my $friend ( @{$r || []} ) {
  0            
883 0           delete $friend->{status};
884 0           $self->add_user($friend);
885 0           $self->yield(friend_join => $friend);
886             }
887 0 0         $self->store($self->state_file) if $self->state_file;
888             };
889              
890             event get_followers_ids => sub {
891 0     0     weaken(my $self = $_[OBJECT]);
892              
893 0           $self->twitter(followers_ids => { cursor => -1 },
894             $_[SESSION]->callback(get_followers_ids_response => {})
895             );
896             };
897              
898             event get_followers_ids_response => sub {
899 0     0     weaken(my $self = $_[OBJECT]);
900 0           my ( $followers ) = @{ $_[ARG0] };
  0            
901 0           my ( $r ) = @{ $_[ARG1] };
  0            
902              
903 0           $$followers{$_} = undef for @{$$r{ids}};
  0            
904              
905 0 0         if ( my $cursor = $r->{next_cursor} ) {
906 0           $self->twitter(follower_ids => { cursor => $cursor },
907             $_[SESSION]->callback(get_followers_ids_response => $followers)
908             );
909 0           return;
910             }
911 0 0         if ( %$followers ) {
912 0           $self->followers($followers);
913 0           $self->followers_updated_at(time);
914              
915 0           $self->yield('set_voice');
916             }
917             };
918              
919             event set_voice => sub {
920 0     0     my $self = $_[OBJECT];
921              
922 0           for my $user ( $self->get_users ) {
923 0 0         my $mode = $self->is_follower_id($$user{id}) ? '+v' : '-v';
924              
925 0           $self->post_ircd(daemon_cmd_mode => $self->irc_botname, $self->irc_channel, $mode,
926             $$user{screen_name});
927             }
928             };
929              
930             ########################################################################
931             # Twitter events
932             ########################################################################
933              
934             event friends_ids => sub {
935 0     0     my ( $self, $kernel, $friends_ids ) = @_[OBJECT, KERNEL, ARG0];
936              
937 0           my $buffer = [];
938 0           for my $id ( @$friends_ids ) {
939 0           my $friend = $self->get_user_by_id($id);
940 0 0 0       if ( !$friend || $self->is_user_stale($friend) ) {
941 0           push @$buffer, $id;
942 0 0         if ( @$buffer == 100 ) {
943 0           $self->yield(lookup_friends => [ @$buffer ]);
944 0           $buffer = [];
945 0           $kernel->run_one_timeslice;
946             }
947             }
948             else {
949 0           $self->yield(friend_join => $friend);
950             }
951             }
952              
953 0           $self->yield(lookup_friends => $buffer);
954 0           $self->yield('get_followers_ids');
955             };
956              
957             event on_tweet => sub {
958 0     0     my ( $self, $status ) = @_[OBJECT, ARG0];
959              
960             # add or freshen user
961 0           $self->add_user($$status{user});
962              
963 0           my $nick = $$status{user}{screen_name};
964 0           my $text = $self->formatted_status_text($status);
965 0 0         if ( $nick eq $self->irc_nickname ) {
966 0           $self->set_topic($text);
967             }
968              
969 0 0         unless ( $self->is_channel_member($nick, $self->irc_channel) ) {
970 0           $self->post_ircd(daemon_cmd_join => $nick, $self->irc_channel);
971             }
972              
973 0           TRACE("on_tweet: <$nick> $text");
974 0           $self->post_ircd(daemon_cmd_privmsg => $nick, $self->irc_channel, $_) for split /[\r\n]+/, $text;
975             };
976              
977             event on_event => sub {
978 0     0     my ( $self, $msg ) = @_[OBJECT, ARG0];
979              
980             ### Potential events:
981             #
982             ## implemented:
983             # retweet
984             # follow unfollow
985             # block unblock
986             # favorite unfavorite
987             #
988             ## unimplemented:
989             # user_update
990             # list_created list_updated list_destroyed
991             # list_member_added list_member_removed
992             # list_user_subscribed list_user_unsubscribed
993              
994 0           my $method = "on_event_$$msg{event}";
995 0 0         return $self->$method($msg) if $self->can($method);
996              
997 0           $self->bot_notice($self->irc_channel, "Unhandled Twitter stream event: $$msg{event}");
998 0           DEBUG("unhandled event", $self->to_pretty_json($msg));
999             };
1000              
1001             sub on_event_follow {
1002 0     0 0   my ( $self, $event ) = @_;
1003              
1004 0 0         if ( my $source = $$event{source} ) {
1005 0 0         my $target = $$event{target} or return;
1006              
1007             # new friend
1008 0 0         if ( $$source{id} eq $self->twitter_id ) {
    0          
1009 0           $self->yield(friend_join => $target);
1010 0           $self->bot_notice($self->irc_channel, qq/Now following $$target{screen_name}./);
1011             }
1012              
1013             # new follower
1014             elsif ( $$target{id} eq $self->twitter_id ) {
1015 0           $self->bot_notice($self->irc_channel, qq`\@$$source{screen_name} "$$source{name}" `
1016             . qq`is following you https://twitter.com/$$source{screen_name}`);
1017 0           $self->add_follower_id($$source{id});
1018             }
1019             }
1020             }
1021              
1022             sub on_event_unfollow {
1023 0     0 0   my ( $self, $event ) = @_;
1024              
1025 0           my $screen_name = $event->{target}{screen_name};
1026 0 0         if( my $user = $self->get_user_by_nick($screen_name) ) {
1027 0           $self->delete_user($user);
1028             }
1029 0           $self->post_ircd(daemon_cmd_part => $screen_name, $self->irc_channel);
1030 0           $self->post_ircd(del_spooked_nick => $screen_name);
1031 0           $self->bot_notice($self->irc_channel, qq/No longer following $screen_name./);
1032             }
1033              
1034 0     0 0   sub on_event_favorite { shift->_favorite_or_retweet(favorited => @_) }
1035 0     0 0   sub on_event_unfavorite { shift->_favorite_or_retweet(unfavorited => @_) }
1036 0     0 0   sub on_event_retweet { shift->_favorite_or_retweet(retweeted => @_) }
1037             sub _favorite_or_retweet {
1038 0     0     my ( $self, $verb, $event ) = @_;
1039              
1040 0           my $status = $$event{target_object};
1041 0 0         my $who = $$event{source}{id} eq $self->twitter_id ? 'You' : $$event{source}{screen_name};
1042 0 0         my $whom = $$event{target}{id} eq $self->twitter_id ? 'your' : "$$event{target}{screen_name}'s";
1043 0           my $link = "https://twitter.com/$$status{user}{screen_name}/status/$$status{id}";
1044 0           my $text = $self->formatted_status_text($status);
1045              
1046 0           $self->bot_notice($self->irc_channel,
1047             elide(qq/$who $verb $whom "$text"/, 80, { marker => '…"' }) . " [$link]");
1048             }
1049              
1050             # No need to alert, here. We also get an on_event_favorite for the same tweet
1051 0     0 0   sub on_event_favorited_retweet {}
1052              
1053             sub on_event_block {
1054 0     0 0   my ( $self, $event ) = @_;
1055              
1056 0           my $target = $$event{target};
1057 0 0         if ( $self->get_user_by_id($$target{id}) ) {
1058 0           $self->post_ircd(daemon_cmd_mode =>
1059             $self->irc_botname, $self->irc_channel, '-v', $$target{screen_name});
1060 0           $self->remove_follower_id($$target{id});
1061             }
1062 0           $self->bot_notice($self->irc_channel, qq/You blocked $$target{screen_name}./);
1063             }
1064              
1065             sub on_event_unblock {
1066 0     0 0   my ( $self, $event ) = @_;
1067              
1068 0           my $target = $$event{target};
1069 0 0         if ( $self->get_user_by_id($$target{id}) ) {
1070 0           $self->post_ircd(daemon_cmd_mode =>
1071             $self->irc_botname, $self->irc_channel, '+v', $$target{screen_name});
1072             }
1073 0           $self->bot_notice($self->irc_channel, qq/You unblocked $$target{screen_name}./);
1074             }
1075              
1076 0     0 0   sub on_event_list_member_added { shift->_list_add_or_remove(qw/added to/, @_) }
1077 0     0 0   sub on_event_list_member_removed { shift->_list_add_or_remove(qw/removed from/, @_) }
1078             sub _list_add_or_remove {
1079 0     0     my ( $self, $verb, $preposition, $event ) = @_;
1080              
1081 0           my $list = $$event{target_object};
1082 0 0         my $who = $$event{source}{id} eq $self->twitter_id ? 'You' : $$event{source}{screen_name};
1083 0 0         my $whom = $$event{target}{id} eq $self->twitter_id ? 'you' : $$event{target}{screen_name};
1084 0           my $link = "https://twitter.com$$list{uri}";
1085              
1086 0           $self->bot_notice($self->irc_channel, "$who $verb $whom $preposition list [$$list{name}]($link)");
1087             }
1088              
1089             event on_direct_message => sub {
1090 0     0     my ( $self, $msg ) = @_[OBJECT, ARG0];
1091              
1092 0 0         if ( $$msg{recipient_screen_name} ne $self->twitter_screen_name ) {
1093 0           INFO('direct message sent to @', $$msg{recipient_screen_name});
1094 0           return;
1095             }
1096              
1097 0           my $nick = $$msg{sender_screen_name};
1098 0           my $sender = $$msg{sender};
1099              
1100 0 0         unless ( $self->nick_exists($nick) ) {
1101             # This shouldn't happen - twitter only allows direct messages to followers, so
1102             # we *should* already have $nick on board.
1103 0           $self->post_ircd(add_spoofed_nick => { nick => $nick, ircname => $$sender{name} });
1104 0           $self->add_user($sender);
1105             }
1106              
1107 0           my $text = $self->formatted_status_text($msg);
1108             $self->post_ircd(daemon_cmd_privmsg => $nick, $self->irc_nickname, $_)
1109 0           for split /\r?\n/, $text;
1110             };
1111              
1112             sub on_event_retweeted_retweet {
1113 0     0 0   my ( $self, $msg ) = @_;
1114              
1115 0           my $screen_name = $msg->{source}{screen_name};
1116 0           my $text = $self->formatted_status_text($msg->{target_object});
1117              
1118 0           $self->bot_notice($self->irc_channel, "$screen_name retweeted your retweet: $text");
1119             }
1120              
1121             ########################################################################
1122             # Commands
1123             ########################################################################
1124              
1125             =head2 COMMANDS
1126              
1127             Commands are entered as public messages in the IRC channel in the form:
1128              
1129             command arg1 arg2 ... argn
1130              
1131             Where the arguments, if any, depend upon the command.
1132              
1133             =over 4
1134              
1135             =item post I<status>
1136              
1137             Post a status update. E.g.,
1138              
1139             post Now cooking tweets with twirc!
1140              
1141             =cut
1142              
1143             event cmd_post => sub {
1144 0     0     my ($self, $channel, $text) = @_[OBJECT, ARG0, ARG1];
1145              
1146 0           TRACE("[cmd_post_status]");
1147              
1148 0 0         return if $self->status_text_too_long($channel, $text);
1149              
1150 0           $self->twitter(update => { status => $text },
1151             $_[SESSION]->callback('cmd_post_response')
1152             );
1153             };
1154              
1155             event cmd_post_response => sub {
1156 0     0     my $self = $_[OBJECT];
1157 0           my ( $r ) = @{ $_[ARG1] };
  0            
1158              
1159 0 0         TRACE(" update returned $r->{id}") if $r;
1160             };
1161              
1162             sub status_text_too_long {
1163 0     0 0   my ( $self, $channel, $text ) = @_;
1164              
1165 0 0         if ( (my $n = $self->_calc_text_length($text) - 140) > 0 ) {
1166 0           $self->bot_says($channel, "$n characters too long.");
1167 0           return $n;
1168             }
1169              
1170 0           return;
1171             }
1172              
1173             sub _calc_text_length {
1174 0     0     my ( $self, $text ) = @_;
1175              
1176 0           my $http_urls = $text =~ s/$RE{URI}{HTTP}//g;
1177 0           my $https_urls = $text =~ s/$RE{URI}{HTTP}{-scheme => 'https'}//g;
1178              
1179 0           return length($text) + $http_urls * 20 + $https_urls * 21;
1180             }
1181              
1182             =item follow I<id>
1183              
1184             Follow a new Twitter user, I<id>. In Twitter parlance, this creates a friendship.
1185              
1186             =cut
1187              
1188             event cmd_follow => sub {
1189 0     0     my ($self, $channel, $id) = @_[OBJECT, ARG0, ARG1];
1190              
1191 0 0         if ( $id !~ /^\w+$/ ) {
1192 0           $self->bot_says($channel, qq/"$id" doesn't look like a user ID to me./);
1193 0           return;
1194             }
1195              
1196 0           $self->twitter(create_friend => { screen_name => $id });
1197             };
1198              
1199             =item unfollow I<id>
1200              
1201             Stop following Twitter user I<id>. In Twitter, parlance, this destroys a
1202             friendship.
1203              
1204             =cut
1205              
1206             event cmd_unfollow => sub {
1207 0     0     my ($self, $channel, $id) = @_[OBJECT, ARG0, ARG1];
1208              
1209 0           my $user = $self->get_user_by_nick($id);
1210 0 0         unless ( $user ) {
1211 0           $self->bot_says($channel, qq/You don't appear to be following $id./);
1212 0           return;
1213             }
1214              
1215 0           $self->twitter(destroy_friend => { screen_name => $id });
1216             };
1217              
1218             =item block I<id>
1219              
1220             Block Twitter user I<id>.
1221              
1222             =cut
1223              
1224             event cmd_block => sub {
1225 0     0     my ($self, $channel, $id) = @_[OBJECT, ARG0, ARG1];
1226              
1227 0 0         if ( $id !~ /^\w+$/ ) {
1228 0           $self->bot_says($channel, qq/"$id" doesn't look like a user ID to me./);
1229 0           return;
1230             }
1231              
1232 0           $self->twitter(create_block => { screen_name => $id });
1233             };
1234              
1235             =item unblock I<id>
1236              
1237             Stop blocking Twitter user I<id>.
1238              
1239             =cut
1240              
1241             event cmd_unblock => sub {
1242 0     0     my ( $self, $channel, $id ) = @_[OBJECT, ARG0, ARG1];
1243              
1244 0 0         if ( $id !~ /^\w+$/ ) {
1245 0           $self->bot_says($self->irc_channel, qq/"$id" doesn't look like a Twitter screen name to me./);
1246 0           return;
1247             }
1248              
1249 0           $self->twitter(destroy_block => { screen_name => $id});
1250             };
1251              
1252             =item whois I<id>
1253              
1254             Displays information about Twitter user I<id>, including name, location, and
1255             description.
1256              
1257             =cut
1258              
1259             event cmd_whois => sub {
1260 0     0     my ($self, $channel, $nick) = @_[OBJECT, ARG0, ARG1];
1261              
1262 0           TRACE("[cmd_whois] $nick");
1263              
1264              
1265 0 0         if ( my $user = $self->get_user_by_nick($nick) ) {
1266 0           $self->yield('cmd_whois_response' => [ $channel, $nick ], [ $user ]);
1267             }
1268             else {
1269 0           TRACE(" $nick not in users; fetching");
1270 0           $self->twitter(show_user => { screen_name => $nick },
1271             $_[SESSION]->callback(cmd_whois_response => $channel, $nick)
1272             );
1273             }
1274             };
1275              
1276             event cmd_whois_response => sub {
1277 0     0     my $self = $_[OBJECT];
1278 0           my ( $channel, $nick ) = @{ $_[ARG0] };
  0            
1279 0           my ( $user ) = @{ $_[ARG1] };
  0            
1280              
1281 0 0         if ( $user ) {
1282 0           $self->bot_says($channel, sprintf '%s [%s]: %s, %s',
1283 0           @{$user}{qw/screen_name id name/},
1284             (map decode_entities(defined $_ ? $_ : ''),
1285 0 0         @{$user}{qw/location description/}),
1286             $$user{url}
1287             );
1288             }
1289             else {
1290 0           $self->bot_says($channel, "I don't know $nick.");
1291             }
1292             };
1293              
1294             =item notify I<on|off> I<screen_name ...>
1295              
1296             Turns mobile device notifications on or off for the list of I<screen_name>s.
1297              
1298             =cut
1299              
1300             event cmd_notify => sub {
1301 0     0     my $self = $_[OBJECT];
1302 0           $self->call(_update_fship => 'device', @_[ARG0, ARG1]);
1303             };
1304              
1305             =item retweets I<on|off> I<screen_name ...>
1306              
1307             Turns retweet display on your timeline on or off for the list of
1308             I<screen_name>s.
1309              
1310             =cut
1311              
1312             event cmd_retweets => sub {
1313 0     0     my $self = $_[OBJECT];
1314 0           $self->call(_update_fship => 'retweets', @_[ARG0, ARG1]);
1315             };
1316              
1317             # Call update_friendships
1318             # All settings updated at once so existing must be preserved
1319             event _update_fship => sub {
1320 0     0     my ($self, $command, $channel, $argstr) = @_[OBJECT, ARG0..ARG2];
1321              
1322 0           my @nicks = split /\s+/, $argstr;
1323 0           my $onoff = shift @nicks;
1324              
1325 0 0 0       unless ( $onoff && $onoff =~ /^on$|^off$/ ) {
1326 0           $self->bot_says($channel, "Usage: $command on|off nick[ nick [...]]");
1327 0           return;
1328             }
1329              
1330 0 0         my $setting = $onoff eq 'on' ? 1 : 0;
1331 0           for my $nick ( @nicks ) {
1332 0           $self->twitter(show_friendship => { target_screen_name => $nick },
1333             $_[SESSION]->callback( _update_fship_response =>
1334             $command, $channel, $nick, $setting
1335             )
1336             );
1337             }
1338             };
1339              
1340             event _update_fship_response => sub {
1341 0     0     my $self = $_[OBJECT];
1342 0 0         my ( $r ) = @{ $_[ARG1] } or return;
  0            
1343 0           my ( $command, $channel, $nick, $setting ) = @{ $_[ARG0] };
  0            
1344              
1345 0           my $source = $r->{relationship}{source};
1346             # Pull out existing settings
1347             # Quoted values to get 0/1 vs weird JSON:: things that break the API
1348 0           my %current_value = (
1349             device => "$source->{notifications_enabled}",
1350             retweets => "$source->{want_retweets}",
1351             );
1352              
1353             # Skip unnecessary updates
1354 0 0         if ( $current_value{$command} == $setting ) {
1355 0           $self->bot_says($channel, "No need to update $nick");
1356 0           return;
1357             }
1358              
1359             # Update
1360 0           $self->twitter(update_friendship => {
1361             screen_name => $nick,
1362             # current values as default
1363             %current_value,
1364             # override with new value
1365             $command => $setting
1366             });
1367             };
1368              
1369             =item favorite I<screen_name> [I<count>]
1370              
1371             Mark a tweet as a favorite. Specify the user by I<screen_name> and select from a
1372             list of recent tweets. Optionally, specify the number of tweets to display for
1373             selection with I<count> (Defaults to 3.)
1374              
1375             =cut
1376              
1377             event cmd_favorite => sub {
1378 0     0     my ($self, $channel, $args) = @_[OBJECT, ARG0, ARG1];
1379              
1380 0           my ($nick, $count) = split /\s+/, $args;
1381 0   0       $count ||= $self->selection_count;
1382              
1383 0           TRACE("[cmd_favorite] $nick");
1384              
1385 0           $self->twitter(user_timeline => { screen_name => $nick, count => $count },
1386             $_[SESSION]->callback(cmd_favorite_response => $channel, $nick)
1387             );
1388             };
1389              
1390             event cmd_favorite_response => sub {
1391 0     0     my $self = $_[OBJECT];
1392 0 0         my ( $recent ) = @{ $_[ARG1] } or return;
  0            
1393 0           my ( $channel, $nick ) = @{ $_[ARG0] };
  0            
1394              
1395 0 0         if ( @$recent == 0 ) {
1396 0           $self->bot_says($channel, "$nick has no recent tweets");
1397 0           return;
1398             }
1399              
1400             $self->stash({
1401 0           handler => '_handle_favorite',
1402             candidates => [ map $$_{id_str}, @$recent ],
1403             });
1404              
1405 0           $self->bot_says($channel, 'Which tweet?');
1406 0           for ( 1..@$recent ) {
1407 0           $self->bot_says($channel, "[$_] " .
1408             elide(
1409             $self->formatted_status_text($recent->[$_ - 1]),
1410             $self->truncate_to
1411             )
1412             );
1413             }
1414             };
1415              
1416             event _handle_favorite => sub {
1417 0     0     my ( $self, $channel, $index ) = @_[OBJECT, ARG0, ARG1];
1418              
1419 0           TRACE("[handle_favorite] $index");
1420              
1421 0           my @candidates = $self->stashed_candidates;
1422 0 0 0       if ( $index =~ /^\d+$/ && 0 < $index && $index <= @candidates ) {
      0        
1423 0           $self->twitter(create_favorite => { id => $candidates[$index - 1] });
1424 0           return 1; # handled
1425             }
1426 0           return 0; # unhandled
1427             };
1428              
1429             =item rate_limit_status
1430              
1431             Displays the remaining number of API requests available in the current hour.
1432              
1433             =cut
1434              
1435             event cmd_rate_limit_status => sub {
1436 0     0     my ($self, $channel) = @_[OBJECT, ARG0];
1437              
1438 0           $self->twitter('rate_limit_status', {},
1439             $_[SESSION]->callback(cmd_rate_limit_status_response => $channel)
1440             );
1441             };
1442              
1443             event cmd_rate_limit_status_response => sub {
1444 0     0     my $self = $_[OBJECT];
1445 0 0         my ( $r ) = @{ $_[ARG1] } or return;
  0            
1446 0           my ( $channel ) = @{ $_[ARG0] };
  0            
1447              
1448 0           my $reset_time = sprintf "%02d:%02d:%02d", (localtime $r->{reset_time_in_seconds})[2,1,0];
1449 0           my $seconds_remaining = $r->{reset_time_in_seconds} - time;
1450 0           my $time_remaining = sprintf "%d:%02d", int($seconds_remaining / 60), $seconds_remaining % 60;
1451 0           $self->bot_says($channel, sprintf "%s API calls remaining for the next %s (until %s), hourly limit is %s",
1452             $$r{remaining_hits},
1453             $time_remaining,
1454             $reset_time,
1455             $$r{hourly_limit},
1456             );
1457             };
1458              
1459             =item retweet I<screen_name> [I<count>]
1460              
1461             Re-tweet another user's status. Specify the user by I<screen_name> and select from a
1462             list of recent tweets. Optionally, specify the number of tweets to display for
1463             selection with I<count> (Defaults to 3.)
1464              
1465             =cut
1466              
1467             event cmd_retweet => sub {
1468 0     0     my ( $self, $channel, $args ) = @_[OBJECT, ARG0, ARG1];
1469              
1470 0 0         unless ( defined $args ) {
1471 0           $self->bot_says($channel, 'usage: retweet nick [-N]');
1472 0           return;
1473             }
1474              
1475 0           my ( $nick, $count ) = split /\s+/, $args;
1476              
1477 0   0       $count ||= $self->selection_count;
1478              
1479 0           $self->twitter(user_timeline => { screen_name => $nick, count => $count },
1480             $_[SESSION]->callback(cmd_retweet_response => $channel, $nick)
1481             );
1482             };
1483              
1484             event cmd_retweet_response => sub {
1485 0     0     my $self = $_[OBJECT];
1486 0 0         my ( $recent ) = @{ $_[ARG1] } or return;
  0            
1487 0           my ( $channel, $nick ) = @{ $_[ARG0] };
  0            
1488              
1489 0 0         if ( @$recent == 0 ) {
1490 0           $self->bot_says($channel, "$nick has no recent tweets");
1491 0           return;
1492             }
1493              
1494             $self->stash({
1495 0           handler => '_handle_retweet',
1496             candidates => [ map $$_{id_str}, @$recent ],
1497             });
1498              
1499 0           $self->bot_says($channel, 'Which tweet?');
1500 0           for ( 1..@$recent ) {
1501 0           $self->bot_says($channel, "[$_] " .
1502             elide(
1503             $self->formatted_status_text($recent->[$_ - 1]),
1504             $self->truncate_to
1505             )
1506             );
1507             }
1508             };
1509              
1510             =item rt I<screen_name> [I<count>]
1511              
1512             An alias for the C<retweet> command.
1513              
1514             =cut
1515              
1516 0     0     event cmd_rt => sub { shift->cmd_retweet(@_) };
1517              
1518             event _handle_retweet => sub {
1519 0     0     my ( $self, $channel, $index ) = @_[OBJECT, ARG0, ARG1];
1520              
1521 0           my @candidates = $self->stashed_candidates;
1522 0 0 0       if ( $index =~ /^\d+$/ && 0 < $index && $index <= @candidates ) {
      0        
1523 0           $self->twitter(retweet => { id => $candidates[$index - 1] });
1524 0           return 1; # handled
1525             }
1526 0           return 0; # unhandled
1527             };
1528              
1529             =item reply I<screen_name> [I<-count>] I<message>
1530              
1531             Reply to another user's status. Specify the user by I<screen_name> and select
1532             from a list of recent tweets. Optionally, specify the number of tweets to
1533             display for selection with I<-count> (Defaults to 3.) Note that the count
1534             parameter is prefixed with a dash.
1535              
1536             =cut
1537              
1538             event cmd_reply => sub {
1539 0     0     my ( $self, $channel, $args ) = @_[OBJECT, ARG0, ARG1];
1540              
1541 0 0         unless ( defined $args ) {
1542 0           $self->bot_says($channel, "usage: reply nick [-N] message-text");
1543 0           return;
1544             }
1545              
1546 0           my ( $nick, $count, $message ) = $args =~ /
1547             ^@?(\S+) # nick; strip leading @ if there is one
1548             \s+
1549             (?:-(\d+)\s+)? # optional count: -N
1550             (.*) # the message
1551             /x;
1552 0 0 0       unless ( defined $nick && defined $message ) {
1553 0           $self->bot_says($channel, "usage: reply nick [-N] message-text");
1554 0           return;
1555             }
1556              
1557 0           $message = "\@$nick $message";
1558 0 0         return if $self->status_text_too_long($channel, $message);
1559              
1560 0   0       $count ||= $self->selection_count;
1561              
1562 0           $self->twitter(user_timeline => { screen_name => $nick, count => $count },
1563             $_[SESSION]->callback(cmd_reply_response => $channel, $nick, $message)
1564             );
1565             };
1566              
1567             event cmd_reply_response => sub {
1568 0     0     my $self = $_[OBJECT];
1569 0 0         my ( $recent ) = @{ $_[ARG1] } or return;
  0            
1570 0           my ( $channel, $nick, $message ) = @{ $_[ARG0] };
  0            
1571              
1572 0 0         if ( @$recent == 0 ) {
1573 0           $self->bot_says($channel, "$nick has no recent tweets");
1574 0           return;
1575             }
1576              
1577             $self->stash({
1578 0           handler => '_handle_reply',
1579             candidates => [ map $_->{id_str}, @$recent ],
1580             message => $message,
1581             });
1582              
1583 0           $self->bot_says($channel, 'Which tweet?');
1584 0           for ( 1..@$recent ) {
1585 0           $self->bot_says($channel, "[$_] " .
1586             elide(
1587             $self->formatted_status_text($recent->[$_ - 1]),
1588             $self->truncate_to
1589             )
1590             );
1591             }
1592             };
1593              
1594             event _handle_reply => sub {
1595 0     0     my ( $self, $channel, $index ) = @_[OBJECT, ARG0, ARG1];
1596              
1597 0           my @candidates = $self->stashed_candidates;
1598 0 0 0       if ( $index =~ /^\d+$/ && 0 < $index && $index <= @candidates ) {
      0        
1599 0           $self->twitter(update => {
1600             status => $self->stashed_message,
1601             in_reply_to_status_id => $candidates[$index - 1],
1602             });
1603 0           return 1; # handled
1604             }
1605 0           return 0; # unhandled
1606             };
1607              
1608             =item report_spam
1609              
1610             Report 1 or more screen names as spammers.
1611              
1612             =cut
1613              
1614             event cmd_report_spam => sub {
1615 0     0     my ( $self, $channel, $args ) = @_[OBJECT, ARG0, ARG1];
1616              
1617 0 0         unless ( $args ) {
1618 0           $self->bot_says($channel, "spam requires list of 1 or more spammers");
1619 0           return;
1620             }
1621              
1622 0           for my $spammer ( split /\s+/, $args ) {
1623 0           $self->yield(report_spam_helper => $spammer);
1624             }
1625             };
1626              
1627             event report_spam_helper => sub {
1628 0     0     my ( $self, $spammer ) = @_[OBJECT, ARG0];
1629              
1630 0           $self->twitter(report_spam => { screen_name => $spammer });
1631             };
1632              
1633             =item add I<screen_name> to I<list-slug>
1634              
1635             Add a user to one of your lists.
1636              
1637             =cut
1638              
1639 0     0     event cmd_add => sub { $_[OBJECT]->_add_remove_list_member(qw/add to/, @_[ARG0, ARG1]) };
1640              
1641             sub _add_remove_list_member {
1642 0     0     my ( $self, $verb, $preposition, $channel, $args ) = @_;
1643              
1644 0   0       my ( $nick, $slug ) = ($args || '') =~ /
1645             ^@?(\w+) # nick; strip leading @ if there is one
1646             \s+$preposition\s+
1647             ([-\w]+) # the list-slug
1648             \s*$
1649             /x;
1650              
1651 0 0         unless ( defined $nick ) {
1652 0           $self->bot_says($channel, "usage: $verb <nick> $preposition <list-slug>");
1653 0           return;
1654             }
1655              
1656 0           $self->twitter($verb . '_list_member' => {
1657             owner_id => $self->twitter_id,
1658             slug => $slug,
1659             screen_name => $nick,
1660             });
1661             };
1662              
1663             =item remove I<screen_name> from I<list-slug>
1664              
1665             Add a user to one of your lists.
1666              
1667             =cut
1668              
1669 0     0     event cmd_remove => sub { $_[OBJECT]->_add_remove_list_member(qw/remove from/, @_[ARG0, ARG1]) };
1670              
1671             =item help
1672              
1673             Display a simple help message
1674              
1675             =cut
1676              
1677             event cmd_help => sub {
1678 0     0     my ($self, $channel, $argstr)=@_[OBJECT, ARG0, ARG1];
1679 0           $self->bot_says($channel, "Available commands:");
1680 0           $self->bot_says($channel, join ' ' => sort qw/
1681             post follow unfollow block unblock whois notify retweets favorite
1682             rate_limit_status retweet report_spam
1683             /);
1684 0           $self->bot_says($channel, '/msg nick for a direct message.')
1685             };
1686              
1687             1;
1688              
1689             __END__
1690              
1691             =item /msg I<id> I<text>
1692              
1693             Sends a direct message to Twitter user I<id> using an IRC private message.
1694              
1695             =back
1696              
1697             =head1 SEE ALSO
1698              
1699             L<App::Twirc>
1700              
1701             =head1 AUTHOR
1702              
1703             Marc Mims <marc@questright.com>
1704              
1705             =head1 CONTRIBUTORS
1706              
1707             Adam Prime <adam.prime@utoronto.ca> (@adamprime)
1708             Peter Roberts <me+dev@peter-r.co.uk>
1709              
1710             =head1 LICENSE
1711              
1712             Copyright (c) 2008 Marc Mims
1713              
1714             You may distribute this code and/or modify it under the same terms as Perl itself.