File Coverage

lib/Colloquy/Bot/Simple.pm

Criterion	Covered	Total	%
statement	3	3	100.0
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	4	4	100.0

############################################################
#
#   $Id: Simple.pm 518 2006-05-29 11:32:23Z nicolaw $
#   Colloquy::Bot::Simple - Simple robot interface for Colloquy
#
#   Copyright 2006 Nicola Worthington
#
#   Licensed under the Apache License, Version 2.0 (the "License");
#   you may not use this file except in compliance with the License.
#   You may obtain a copy of the License at
#
#       http://www.apache.org/licenses/LICENSE-2.0
#
#   Unless required by applicable law or agreed to in writing, software
#   distributed under the License is distributed on an "AS IS" BASIS,
#   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#   See the License for the specific language governing permissions and
#   limitations under the License.
#
############################################################

package Colloquy::Bot::Simple;
# vim:ts=4:sw=4:tw=78

use base qw(Chatbot::TalkerBot);

use strict;
no warnings qw(redefine);

use Exporter;
use Carp qw(croak cluck carp confess);
use Parse::Colloquy::Bot qw(:all);

use vars qw(@EXPORT @EXPORT_OK $VERSION);

@EXPORT = qw(&connect_through_firewall &connect_directly &daemonize);
@EXPORT_OK = qw(TB_TRACE TB_LOG);

$VERSION = '1.08' || sprintf('%d', q$Revision: 518 $ =~ /(\d+)/g);

sub TB_LOG { Chatbot::TalkerBot::TB_TRACE(@_); }
sub TB_TRACE { Chatbot::TalkerBot::TB_TRACE(@_); }

sub listenLoop {
	my $self = shift;
	my $callback = shift;
	my $interrupt = shift;

	# check that any supplied callback is a coderef
	if ($callback && (ref( $callback ) ne 'CODE')) { die("The callback must be a code reference"); }
	if ($interrupt) { TB_LOG("Installing interrupt handler every $interrupt secs"); }

	my $STOPLOOP = 0;
	local $SIG{'ALRM'} = ($interrupt? sub { $callback->($self, 'ALRM'); alarm($interrupt); } : 'IGNORE');
	alarm($interrupt) if $interrupt;

	# enter event loop
	TB_LOG("Entering listening loop");
	my $socket = $self->{'connection'};

	while( <$socket> ) {
		# we don't know how long it will take to process this line, so stop interrupts
		alarm(0) if $interrupt;

		s/[\n\r]//g;

		# only pay any attention to that regular expression
		if ($self->{'AnyCommands'} == 1) {
			my $args = Parse::Colloquy::Bot::parse_line($_);
			$args->{alarm} = 0;

			TB_LOG("Attending: <$args->{msgtype}> = <$args->{text}>");
			$self->{'lines_in'} += 1;

			$STOPLOOP = $callback->($self, %{$args});
		}

		# command processing done, turn interrupts back on
		last if $STOPLOOP;
		alarm($interrupt) if $interrupt;
	}
	TB_LOG("Fallen out of listening loop");
}


sub new {
	my $class = shift;
	croak "Odd number of elements passed when even was expected"
		if @_ % 2;

	my $self = {};
	while (my $key = shift(@_)) {
		$self->{lc($key)} = shift(@_);
	}

	for my $key qw(username password host port) {
		unless (exists $self->{$key} && length($self->{$key})) {
			croak "No '$key' value was specified";
		}
	}

	my $socket = Chatbot::TalkerBot::connect_directly(
			$self->{host},
			$self->{port}
		);

	my $talker = $class->SUPER::new($socket, {
			Username => $self->{username},
			Password => $self->{password},
			UsernameResponse => $self->{usernameresponse} || ' ',
			UsernamePrompt => $self->{usernameprompt} || 'HELLO colloquy',
			PasswordPrompt => $self->{passwordprompt} || '',
			PasswordResponse => $self->{passwordresponse} || '',
			LoginSuccess => $self->{loginsuccess} || 'MARK ---',
			LoginFail => $self->{loginfail} || 'Incorrect login',
			#NoCommands => 1,
		});

	return $talker;
}

sub _is_list {
	local $_ = shift || '';
	if (/^LIST.+\{(\w+?)\}\s*$/) {
		return '%'.$1;
	} elsif (/^OBSERVED\s+(\S+)\s+/) {
		return '@'.$1;
	}
	return undef;
}

# Daemonize self
sub daemonize {
	# Pass in the PID filename to use
	my $pidfile = shift || undef;

	# Boolean true will supress "already running" messages if you want to
	# spawn a process out of cron every so often to ensure it's always
	# running, and to respawn it if it's died
	my $cron = shift || 0;

	# Set the fname to the filename minus path
	(my $SELF = $0) =~ s|.*/||;
	$0 = $SELF;

	# Lazy people have to have everything done for them!
	$pidfile = "/tmp/$SELF.pid" unless defined $pidfile;

	# Check that we're not already running, and quit if we are
	if (-f $pidfile) {
		unless (open(PID,$pidfile)) {
			warn "Unable to open file handle PID for file '$pidfile': $!\n";
			exit 1;
		}
		my $pid = ; chomp $pid;
		close(PID) || warn "Unable to close file handle PID for file '$pidfile': $!\n";

		# This is a good method to check the process is still running for Linux
		# kernels since it checks that the fname of the process is the same as
		# the current process
		if (-f "/proc/$pid/stat") {
			open(FH,"/proc/$pid/stat") || warn "Unable to open file handle FH for file '/proc/$pid/stat': $!\n";
			my $line = ;
			close(FH) || warn "Unable to close file handle FH for file '/proc/$pid/stat': $!\n";
			if ($line =~ /\d+[^(]*\((.*)\)\s*/) {
				my $process = $1;
				if ($process =~ /^$SELF$/) {
					warn "$SELF already running at PID $pid; exiting.\n" unless $cron;
					exit 0;
				}
			}

		# This will work on other UNIX flavors but doesn't gaurentee that the
		# PID you've just checked is the same process fname as reported in you
		# PID file
		} elsif (kill(0,$pid)) {
			warn "$SELF already running at PID $pid; exiting.\n" unless $cron;
			exit 0;

		# Otherwise the PID file is old and stale and it should be removed
		} else {
			warn "Removing stale PID file.\n";
			unlink($pidfile) || warn "Unable to unlink PID file '$pidfile': $!\n";
		}
	}

	# Daemon parent about to spawn
	if (my $pid = fork) {
		warn "Forking background daemon, process $pid.\n";
		exit 0;

	# Child daemon process that was spawned
	} else {
		# Fork a second time to get rid of any attached terminals
		if (my $pid = fork) {
			warn "Forking second background daemon, process $pid.\n";
			exit 0;
		} else {
			unless (defined $pid) {
				warn "Cannot fork: $!\n";
				exit 2;
			}
			unless (open(FH,">$pidfile")) {
				warn "Unable to open file handle FH for file '$pidfile': $!\n";
				exit 3;
			}
			print FH $$;
			close(FH) || warn "Unable to close file handle FH for file '$pidfile': $!\n";

			# Sort out file handles and current working directory
			chdir '/' || warn "Unable to change directory to '/': $!\n";
			close(STDOUT) || warn "Unable to close file handle STDOUT: $!\n";
			close(STDERR) || warn "Unable to close file handle STDERR: $!\n";
			open(STDOUT,'>>/dev/null'); open(STDERR,'>>/dev/null');

			return $$;
		}
	}
}

1;

=pod

=head1 NAME

Colloquy::Bot::Simple - Simple robot interface for Colloquy

=head1 SYNOPSIS

 use Colloquy::Bot::Simple qw(daemonize);

 # Create a connection
 my $talker = Colloquy::Bot::Simple->new(
          host => '127.0.0.1',
          port => 1236,
          username => 'MyBot',
          password => 'topsecret',
     );

 # Daemonize in to the background
 daemonize("/tmp/MyBot.pid","quiet");

 # Execute callback on speech and "alarm" every 60 seconds
 $talker->listenLoop(\&event_callback, 60);

 # Tidy up and finish
 $talker->quit();
 exit;

 sub event_callback {
     my $talker = shift;
     my $event = @_ % 2 ? { alarm => 1 } : { @_ };

     if (exists $event->{alarm}) {
         print "Callback called as ALARM interrupt handler\n";
         # ... go check an RSS feed for new news items to inform
         #     your users about or something else nice maybe ...?

     } elsif (lc($event->{command}) eq 'hello') {
         $talker->whisper(
                 (exists $event->{list} ? $event->{list} : $event->{person}),
                 "Hi there $event->{person}"
             );

     } elsif ($event->{msgtype} eq 'TELL') {
         $talker->whisper($event->{person}, 'Pardon?');
     }

     # Return boolean false to continue the listenLoop
     return 0;
 }

=head1 DESCRIPTION

A very simple robot interface to connect and interact with a Colloquy talker,
based upon Chatbot::TalkerBot.

=head1 METHODS

=head2 new

=head2 daemonize

=head2 listenLoop

=head2 say

=head2 whisper

=head2 quit

=head1 TODO

Write some decent POD.

=head1 SEE ALSO

L, L, L

=head1 VERSION

$Id: Simple.pm 518 2006-05-29 11:32:23Z nicolaw $

=head1 AUTHOR

Nicola Worthington

L

=head1 COPYRIGHT

Copyright 2006 Nicola Worthington.

This software is licensed under The Apache Software License, Version 2.0.

L

=cut