File Coverage

blib/lib/Chatbot/Alpha.pm

Criterion	Covered	Total	%
statement	12	451	2.6
branch	0	176	0.0
condition	0	29	0.0
subroutine	4	17	23.5
pod	12	13	92.3
total	28	686	4.0

package Chatbot::Alpha;

our $VERSION = '2.05';

# For debugging...
use strict;
use warnings;
use Data::Dumper;

# Syntax checking
use Chatbot::Alpha::Syntax;

sub new {
	my $proto = shift;

	my $class = ref($proto) || $proto;

	my $self = {
		debug   => 0,
		version => $VERSION,
		default => "I'm afraid I don't know how to reply to that!",
		stream  => undef,
		syntax  => new Chatbot::Alpha::Syntax(
			syntax   => 'strict',
			denytype => 'allow_all',
		),
		verify  => 1,
		@_,
	};

	bless ($self,$class);

	return $self;
}

sub version {
	my $self = shift;

	return $self->{version};
}

sub debug {
	my ($self,$msg) = @_;

	# Only show if debug mode is on.
	if ($self->{debug} == 1) {
		print STDOUT "Alpha::Debug // $msg\n";
	}

	return 1;
}

sub loadFolder {
	my ($self,$dir) = (shift,shift);
	my $type = shift || undef;

	# Open the folder.
	opendir (DIR, $dir) or return 0;
	foreach my $file (sort(grep(!/^\./, readdir(DIR)))) {
		if (defined $type) {
			if ($file !~ /\.$type$/i) {
				next;
			}
		}

		my $load = $self->loadFile ("$dir/$file");
		return $load unless $load == 1;
	}
	closedir (DIR);

	return 1;
}

sub stream {
	my ($self,$code) = @_;

	# Must have Alpha code defined.
	if (!defined $code) {
		warn "Chatbot::Alpha::stream - no code included with call!\n";
		return 0;
	}

	# Stream the code.
	$self->{stream} = $code;
	$self->loadFile (undef,1);
}

sub loadFile {
	my ($self,$file,$stream) = @_;
	$stream = 0 unless defined $stream;
	$stream = 0 if defined $file;

	$file = '(Streamed)' unless defined $file;

	$self->debug ("loadFile called for file: $file");

	# Open the file.
	my @data = ();
	if ($stream != 1) {
		# Syntax check this.
		if ($self->{verify} == 1) {
			$self->{syntax}->check ($file);
		}

		open (FILE, "$file") or return 0;
		@data = ;
		close (FILE);
		chomp @data;
	}
	else {
		@data = split ("\n", $self->{stream});
	}

	# (Re)-define temporary variables.
	my $topic = 'random';
	my $inReply = 0;
	my $trigger = '';
	my $counter = 0;
	my $ccount = 0; # Conditions counter
	my $holder = 0;
	my $num = 0;

	# Go through the file.
	foreach my $line (@data) {
		$num++;
		$self->debug ("Line $num: $line");
		next if length $line == 0;
		next if $line =~ /^\//;
		$line =~ s/^\s+//g;
		$line =~ s/^\t+//g;
		$line =~ s/^\s//g;
		$line =~ s/^\t//g;

		# Get the command off.
		my ($command,$data) = split(//, $line, 2);

		# Go through commands...
		if ($command eq '>') {
			$self->debug ("> Command - Label Begin!");
			$data =~ s/^\s//g;
			my ($type,$text) = split(/\s+/, $data, 2);
			if ($type eq 'topic') {
				$self->debug ("Topic set to $data");
				$topic = $text;
			}
		}
		elsif ($command eq '<') {
			$self->debug ("< Command - Label Ender!");
			$data =~ s/^\s//g;
			if ($data eq 'topic' || $data eq '/topic') {
				$self->debug ("Topic reset");
				$topic = 'random';
			}
		}
		elsif ($command eq '+') {
			$self->debug ("+ Command - Reply Trigger!");
			if ($inReply == 1) {
				# Reset the topics?
				if ($topic =~ /^_that_/i) {
					$topic = 'random';
				}

				# New reply.
				$inReply = 0;
				$trigger = '';
				$counter = 0;
				$holder = 0;
			}

			# Reply trigger.
			$inReply = 1;

			$data =~ s/^\s//g;
			$data =~ s/([^A-Za-z0-9 ])/\\$1/ig;
			$data =~ s/\\\*/\(\.\*\?\)/ig;
			$trigger = $data;
			$self->debug ("Trigger: $trigger");

			# Set the trigger's topic.
			$self->{_replies}->{$topic}->{$trigger}->{topic} = $topic;
			$self->{_syntax}->{$topic}->{$trigger}->{ref} = "$file line $num";
		}
		elsif ($command eq '~') {
			$self->debug ("~ Command - Regexp Trigger!");
			if ($inReply == 1) {
				# Reset the topics?
				if ($topic =~ /^_that_/i) {
					$topic = 'random';
				}

				# New reply.
				$inReply = 0;
				$trigger = '';
				$counter = 0;
				$holder = 0;
			}

			# Reply trigger.
			$inReply = 1;

			$data =~ s/^\s//g;
			$trigger = $data;
			$self->debug ("Trigger: $trigger");

			# Set the trigger's topic.
			$self->{_replies}->{$topic}->{$trigger}->{topic} = $topic;
			$self->{_syntax}->{$topic}->{$trigger}->{ref} = "$file line $num";
		}
		elsif ($command eq '%') {
			$self->debug ("% Command - That!");
			if ($inReply != 1) {
				# Error.
				$self->debug ("Syntax error at $file line $num");
				return -2;
			}

			# That tag.
			$data =~ s/^\s//g;

			# Set the topic to "_that_$data"
			$topic = "_that_$data";
		}
		elsif ($command eq '-') {
			$self->debug ("- Command - Reply Response!");
			if ($inReply != 1) {
				# Error.
				$self->debug ("Syntax Error at $file line $num");
				return -2;
			}

			# Reply response.
			$counter++;
			$data =~ s/^\s//g;

			$self->{_replies}->{$topic}->{$trigger}->{$counter} = $data;
			$self->debug ("Reply #$counter : $data");
			$self->{_syntax}->{$topic}->{$trigger}->{$counter}->{ref} = "$file line $num";
		}
		elsif ($command eq '^') {
			$self->debug ("^ Command - Reply Continuation");
			$data =~ s/^\s//g;
			$self->{_replies}->{$topic}->{$trigger}->{$counter} .= $data;
		}
		elsif ($command eq '@') {
			# A redirect.
			$self->debug ("\@ Command - A Redirect!");
			if ($inReply != 1) {
				# Error.
				$self->debug ("Syntax Error at $file line $num");
				return -2;
			}
			$data =~ s/^\s//g;
			$self->{_replies}->{$topic}->{$trigger}->{redirect} = $data;
			$self->{_syntax}->{$topic}->{$trigger}->{redirect}->{ref} = "$file line $num";
		}
		elsif ($command eq '*') {
			# A conditional.
			$self->debug ("* Command - A Conditional!");
			if ($inReply != 1) {
				# Error.
				$self->debug ("Syntax Error at $file line $num");
				return -2;
			}
			# Get the conditional's data.
			$data =~ s/^\s//g;
			$self->debug ("Counter: $ccount");
			$self->{_replies}->{$topic}->{$trigger}->{conditions}->{$ccount} = $data;
			$self->{_syntax}->{$topic}->{$trigger}->{conditions}->{$ccount}->{ref} = "$file line $num";
			$ccount++;
		}
		elsif ($command eq '&') {
			# A conversation holder.
			$self->debug ("\& Command - A Conversation Holder!");
			if ($inReply != 1) {
				# Error.
				$self->debug ("Syntax Error at $file line $num");
				return -2;
			}

			# Save this.
			$data =~ s/^\s//g;
			$self->debug ("Holder: $holder");
			$self->{_replies}->{$topic}->{$trigger}->{convo}->{$holder} = $data;
			$self->{_syntax}->{$topic}->{$trigger}->{convo}->{$holder}->{ref} = "$file line $num";
			$holder++;
		}
		elsif ($command eq '#') {
			# A system command.
			$self->debug ("\# Command - A System Command!");
			if ($inReply != 1) {
				# Error.
				$self->debug ("Syntax Error at $file line $num");
				return -2;
			}

			# Save this.
			$data =~ s/^\s//g;
			$self->debug ("System Command: $data");
			$self->{_replies}->{$topic}->{$trigger}->{system}->{codes} .= $data;
			$self->{_syntax}->{$topic}->{$trigger}->{system}->{codes}->{ref} = "$file line $num";
		}
	}

	return 1;
}

sub sortReplies {
	my $self = shift;

	# Reset loop.
	$self->{loops} = 0;

	# Fail if replies hadn't been loaded.
	return 0 unless exists $self->{_replies};

	# Delete the replies array (if it exists).
	if (exists $self->{_array}) {
		delete $self->{_array};
	}

	$self->debug ("Sorting the replies...");

	# Count replies.
	my $count = 0;

	# Go through each reply.
	foreach my $topic (keys %{$self->{_replies}}) {
		# Sort by number of whole words.
		my $sort = {
			def => [],
			0 => [],
			1 => [],
			2 => [],
			3 => [],
			4 => [],
			5 => [],
			6 => [],
			7 => [],
			8 => [],
			9 => [],
			10 => [],
			11 => [],
			12 => [],
			13 => [],
			14 => [],
			15 => [],
			16 => [],
			unknown => [],
		};

		my @trigNorm = ();
		my @trigWild = ();
		foreach my $key (keys %{$self->{_replies}->{$topic}}) {
			$self->debug ("Sorting key $key");
			$count++;
			# If it's a wildcard...
			if ($key =~ /\*/) {
				# See how many full words it has.
				my @words = split(/\s/, $key);
				my $cnt = 0;
				foreach my $word (@words) {
					$word =~ s/\s//g;
					next unless length $word;
					if ($word !~ /\*/) {
						# A whole word.
						$cnt++;
					}
				}

				# Save to wildcard array.
				$self->debug ("Key $key has a wildcard ($cnt words)!");

				if (exists $sort->{$cnt}) {
					push (@{$sort->{$cnt}}, $key);
				}
				else {
					push (@{$sort->{unknown}}, $key);
				}
			}
			else {
				# Save to normal array.
				$self->debug ("Key $key is normal!");
				push (@{$sort->{def}}, $key);
			}
		}

		# Merge the arrays.
		$self->{_array}->{$topic} = [
			@{$sort->{def}},
			@{$sort->{16}},
			@{$sort->{15}},
			@{$sort->{14}},
			@{$sort->{13}},
			@{$sort->{12}},
			@{$sort->{11}},
			@{$sort->{10}},
			@{$sort->{9}},
			@{$sort->{8}},
			@{$sort->{7}},
			@{$sort->{6}},
			@{$sort->{5}},
			@{$sort->{4}},
			@{$sort->{3}},
			@{$sort->{2}},
			@{$sort->{1}},
			@{$sort->{unknown}},
			@{$sort->{0}},
		];
	}

	# Save the count.
	$self->{replycount} = $count;

	# Return true.
	return 1;
}

sub setVariable {
	my ($self,$var,$value) = @_;
	return 0 unless defined $var;
	return 0 unless defined $value;

	$self->{vars}->{$var} = $value;
	return 1;
}

sub removeVariable {
	my ($self,$var) = @_;
	return 0 unless defined $var;

	delete $self->{vars}->{$var};
	return 1;
}

sub clearVariables {
	my $self = shift;

	delete $self->{vars};
	return 1;
}

sub search {
	my ($self,$msg) = @_;

	my @results = ();

	# Sort replies if it hasn't already been done.
	if (!exists $self->{_array}) {
		$self->sortReplies;
	}

	# Too many loops?
	if ($self->{loops} >= 15) {
		$self->{loops} = 0;
		my $topic = 'random';
		return "ERR: Deep Recursion (15+ loops in reply set) at $self->{_syntax}->{$topic}->{$msg}->{redirect}->{ref}";
	}

	my %star;
	my $reply;

	# Make sure some replies are loaded.
	if (!exists $self->{_replies}) {
		return "ERROR: No replies have been loaded!";
	}

	# Go through each reply.
	foreach my $topic (keys %{$self->{_array}}) {
		$self->debug ("On Topic: $topic");

		foreach my $in (@{$self->{_array}->{$topic}}) {
			$self->debug ("On Reply Trigger: $in");

			if ($msg =~ /^$in$/i) {
				# Add to the results.
				my $t = $in;
				$t =~ s/\(\.\*\?\)/\*/g;
				push (@results, "+ $t (topic: $topic) at $self->{_syntax}->{$topic}->{$in}->{ref}");
			}
		}
	}

	return @results;
}

sub reply {
	my ($self,$id,$msg) = @_;

	# Sort replies if it hasn't already been done.
	if (!exists $self->{_array}) {
		$self->sortReplies;
	}

	# Create history.
	if (!exists $self->{users}->{$id}->{history}) {
		$self->{users}->{$id}->{history}->{input} = [ '', 'undefined', 'undefined', 'undefined', 'undefined',
			'undefined', 'undefined', 'undefined', 'undefined', 'undefined' ];
		$self->{users}->{$id}->{history}->{reply} = [ '', 'undefined', 'undefined', 'undefined', 'undefined',
			'undefined', 'undefined', 'undefined', 'undefined', 'undefined' ];
	}

	# Too many loops?
	if ($self->{loops} >= 15) {
		$self->{loops} = 0;
		my $topic = $self->{users}->{$id}->{topic} || 'random';
		return "ERR: Deep Recursion (15+ loops in reply set) at $self->{_syntax}->{$topic}->{$msg}->{redirect}->{ref}";
	}

	my %star;
	my $reply;

	for (my $i = 1; $i <= 9; $i++) {
		$star{$i} = '';
	}

	# Topics?
	$self->{users}->{$id}->{topic} ||= 'random';

	$self->{users}->{$id}->{last} = '' unless exists $self->{users}->{$id}->{last};
	$self->{users}->{$id}->{that} = '' unless exists $self->{users}->{$id}->{that};

	$self->debug ("User Topic: $self->{users}->{$id}->{topic}");

	$self->debug ("Message: $msg");

	# Make sure some replies are loaded.
	if (!exists $self->{_replies}) {
		return "ERROR: No replies have been loaded!";
	}

	# See if this topic has any "that's" associated with it.
	my $thatTopic = "_that_$self->{users}->{$id}->{that}";
	my $isThat = 0;
	my $keepTopic = '';

	# Go through each reply.
	foreach my $topic (keys %{$self->{_array}}) {
		$self->debug ("On Topic: $topic");

		my $lastSent = $self->{users}->{$id}->{that};

		if ($isThat != 1 && length $lastSent > 0 && exists $self->{_replies}->{$thatTopic}->{$msg}) {
			# It does exist. Set this as the topic so this reply should be matched.
			$isThat = 1;
			$keepTopic = $self->{users}->{$id}->{topic};
			$self->{users}->{$id}->{topic} = $thatTopic;
		}

		next unless $topic eq $self->{users}->{$id}->{topic};

		foreach my $in (@{$self->{_array}->{$topic}}) {
			$self->debug ("On Reply Trigger: $in");

			# Conversations?
			my $found_convo = 0;
			$self->debug ("Checking for conversation holders...");
			if (exists $self->{_replies}->{$topic}->{$in}->{convo}) {
				$self->debug ("This reply has a convo holder!");
				# See if this was our conversation.
				my $h = 0;
				for ($h = 0; exists $self->{_replies}->{$topic}->{$in}->{convo}->{$h}; $h++) {
					last if $found_convo == 1;
					$self->debug ("On Holder #$h");

					my $next = $self->{_replies}->{$topic}->{$in}->{convo}->{$h};

					$self->debug ("Last Msg: $self->{users}->{$id}->{last}");

					# See if this was for their last message.
					if ($self->{users}->{$id}->{last} =~ /^$in$/i) {
						if (!exists $self->{_replies}->{$topic}->{$in}->{convo}->{$self->{users}->{$id}->{hold}}) {
							delete $self->{users}->{$id}->{hold};
							$self->{users}->{$id}->{last} = $msg;
							last;
						}

						# Give the reply.
						$reply = $self->{_replies}->{$topic}->{$in}->{convo}->{$self->{users}->{$id}->{hold}};
						$self->{users}->{$id}->{hold}++;
						$star{msg} = $msg;
						$msg = $in;
						$found_convo = 1;
					}
				}
			}
			last if defined $reply;

			if ($msg =~ /^$in$/i) {
				$self->debug ("Reply Matched!");
				$star{1} = $1; $star{2} = $2; $star{3} = $3; $star{4} = $4; $star{5} = $5;
				$star{6} = $6; $star{7} = $7; $star{8} = $8; $star{9} = $9;

				# A redirect?
				$self->debug ("Checking for a redirection...");
				if (exists $self->{_replies}->{$topic}->{$in}->{redirect}) {
					$self->debug ("Redirection found! Getting new reply for $self->{_replies}->{$topic}->{$in}->{redirect}...");
					my $redirect = $self->{_replies}->{$topic}->{$in}->{redirect};

					# Filter in wildcards.
					for (my $s = 0; $s <= 9; $s++) {
						$redirect =~ s//$star{$s}/ig;
					}

					$redirect =~ s//$star{1}/ig if exists $star{1};

					$self->{loops}++;
					$reply = $self->reply ($id,$redirect);
					return $reply;
				}

				# Conditionals?
				$self->debug ("Checking for conditionals...");
				if (exists $self->{_replies}->{$topic}->{$in}->{conditions}) {
					$self->debug ("This response DOES have conditionals!");
					# Go through each one.
					my $c = 0;
					for ($c = 0; exists $self->{_replies}->{$topic}->{$in}->{conditions}->{$c}; $c++) {
						$self->debug ("On Condition #$c");
						last if defined $reply;

						my $conditional = $self->{_replies}->{$topic}->{$in}->{conditions}->{$c};
						my ($condition,$happens) = split(/::/, $conditional, 2);
						$self->debug ("Condition: $condition");
						my ($var,$value) = split(/=/, $condition, 2);
						$self->debug ("var = $var; value = $value");

						if (exists $self->{vars}->{$var}) {
							$self->debug ("Variable asked for exists!");
							# Check values.
							if (($var =~ /^[0-9]/ && $self->{vars}->{$var} eq $value) || ($self->{vars}->{$var} eq $value)) {
								$self->debug ("Values match!");
								# True. This is the reply.
								$reply = $happens;
								$self->debug ("Reply = $reply");
							}
						}
					}
				}

				last if defined $reply;

				# A reply?
				return "ERROR: No reply set for \"$msg\"!" unless exists $self->{_replies}->{$topic}->{$in}->{1};

				my @replies;
				foreach my $key (keys %{$self->{_replies}->{$topic}->{$in}}) {
					next if $key =~ /[^0-9]/;
					push (@replies,$self->{_replies}->{$topic}->{$in}->{$key});
				}

				$reply = 'INFLOOP';
				while ($reply =~ /^(INFLOOP|HASH|SCALAR|ARRAY)/i) {
					$self->{loops}++;
					$reply = $replies [ int(rand(scalar(@replies))) ];
					if ($self->{loops} >= 20) {
						$reply = "ERR: Infinite Loop near $self->{_syntax}->{$topic}->{$in}->{ref}";
					}
				}

				$self->debug ("Checking system commands...");
				# Execute system commands?
				if (exists $self->{_replies}->{$topic}->{$in}->{system}->{codes}) {
					$self->debug ("Found System: $self->{_replies}->{$topic}->{$in}->{system}->{codes}");
					my $eval = eval ($self->{_replies}->{$topic}->{$in}->{system}->{codes}) || $@;
					$self->debug ("Eval Result: $eval");
				}
			}
		}
	}

	# Reset "That" topics.
	if ($isThat == 1) {
		$self->{users}->{$id}->{topic} = $keepTopic;
		$self->{users}->{$id}->{that} = '<>';
	}

	# A reply?
	if (defined $reply) {
		# Filter in stars...
		my $i;
		for ($i = 1; $i <= 9; $i++) {
			$reply =~ s//$star{$i}/ig;
		}
		$reply =~ s//$star{1}/ig if exists $star{1};
		$reply =~ s//$star{msg}/ig if exists $star{msg};
	}
	else {
		# Were they in a topic?
		if ($self->{users}->{$id}->{topic} ne 'random') {
			if (exists $self->{_array}->{$self->{users}->{$id}->{topic}}) {
				$reply = "ERR: No Reply Matched in Topic $self->{users}->{$id}->{topic}";
			}
			else {
				$self->{users}->{$id}->{topic} = 'random';
				$reply = "ERR: No Reply (possibly void topic?)";
			}
		}
		else {
			$reply = "ERR: No Reply Found";
		}
	}

	# History tags.
	$reply =~ s//$self->{users}->{$id}->{history}->{input}->[$1]/g;
	$reply =~ s//$self->{users}->{$id}->{history}->{reply}->[$1]/g;

	# String modifiers.
	while ($reply =~ /\{(formal|uppercase|lowercase|sentence)\}(.*?)\{\/(formal|uppercase|lowercase|sentence)\}/i) {
		my ($type,$string) = ($1,$2);
		$type = lc($type);
		my $o = $string;
		$string = &stringUtil ($type,$string);
		$o =~ s/([^A-Za-z0-9 =<>])/\\$1/g;
		$reply =~ s/\{$type\}$o\{\/$type\}/$string/ig;
	}

	# A topic setter?
	if ($reply =~ /\{topic=(.*?)\}/i) {
		my $to = $1;
		if ($to eq 'random') {
			$self->{users}->{$id}->{topic} = '';
		}
		else {
			$self->{users}->{$id}->{topic} = $to;
		}
		$reply =~ s/\{topic=(.*?)\}//g;
	}

	# Sub-replies?
	while ($reply =~ /\{\@(.*?)\}/i) {
		my $o = $1;
		my $trig = $o;
		$trig =~ s/^\s+//g;
		$trig =~ s/\s$//g;

		my $resp = $self->reply ($id,$trig);

		$reply =~ s/\{\@$o\}/$resp/i;
	}

	# Randomness?
	while ($reply =~ /\{random\}(.*?)\{\/random\}/i) {
		my $text = $1;
		my @options = ();

		# Pipes?
		if ($text =~ /\|/) {
			@options = split(/\|/, $text);
		}
		else {
			@options = split(/\s+/, $text);
		}

		my $rep = $options [ int(rand(scalar(@options))) ];
		$reply =~ s/\{random\}(.*?)\{\/random\}/$rep/i;
	}

	# Update history.
	shift (@{$self->{users}->{$id}->{history}->{input}});
	shift (@{$self->{users}->{$id}->{history}->{reply}});
	unshift (@{$self->{users}->{$id}->{history}->{input}}, $msg);
	unshift (@{$self->{users}->{$id}->{history}->{reply}}, $reply);
	unshift (@{$self->{users}->{$id}->{history}->{input}}, '');
	unshift (@{$self->{users}->{$id}->{history}->{reply}}, '');
	pop (@{$self->{users}->{$id}->{history}->{input}});
	pop (@{$self->{users}->{$id}->{history}->{reply}});

	# Format the bot's reply.
	my $simple = lc($reply);
	$simple =~ s/[^A-Za-z0-9 ]//g;
	$simple =~ s/^\s+//g;
	$simple =~ s/\s$//g;

	# Save this message.
	$self->debug ("Saving this as last msg...");
	$self->{users}->{$id}->{that} = $simple;
	$self->{users}->{$id}->{last} = $msg;
	$self->{users}->{$id}->{hold} ||= 0;

	# Reset the loop timer.
	$self->{loops} = 0;

	# There SHOULD be a reply now.
	# So, return it.
	return $reply;
}

sub stringUtil {
	my ($type,$string) = @_;

	if ($type eq 'uppercase') {
		return uc($string);
	}
	elsif ($type eq 'lowercase') {
		return lc($string);
	}
	elsif ($type eq 'sentence') {
		$string = lc($string);
		return ucfirst($string);
	}
	elsif ($type eq 'formal') {
		$string = lc($string);
		my @words = split(/ /, $string);
		my @out = ();
		foreach my $word (@words) {
			push (@out, ucfirst($word));
		}
		return join (" ", @out);
	}
	else {
		return $string;
	}
}

1;
__END__