File Coverage

blib/lib/Chatbot/Alpha/Syntax.pm

Criterion	Covered	Total	%
statement	6	96	6.2
branch	0	96	0.0
condition	0	3	0.0
subroutine	2	8	25.0
pod	6	6	100.0
total	14	209	6.7

package Chatbot::Alpha::Syntax;

our $VERSION = '0.4';

use strict;
use warnings;

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;

	my $self = {
		debug    => 0,
		version  => $VERSION,
		deny     => {},
		allow    => {},
		denytype => 'alloy_all', # deny_all, allow_some, deny_some
		cusdeny  => 0,
		syntax   => 'strict',
	};

	bless ($self,$class);
	return $self;
}

sub syntax {
	my ($self,$syn) = @_;

	if ($syn =~ /^(loose|strict)$/i) {
		$self->{syntax} = $syn;
		return 1;
	}

	return 0;
}

sub deny_type {
	my ($self,$type) = @_;

	if ($type =~ /^(alloy|deny)_(all|some)$/i) {
		$self->{cusdeny} = 1;

		$type = lc($type);
		$type =~ s/ //g;

		$self->{denytype} = $type;
	}
	else {
		return 0;
	}
	return 1;
}

sub deny {
	my ($self,@commands) = @_;

	# Deny each command.
	foreach my $cmd (@commands) {
		delete $self->{allow}->{$cmd} if exists $self->{allow}->{$cmd};
		$self->{deny}->{$cmd} = 1;
	}

	$self->deny_type ('deny_some') unless $self->{cusdeny} == 1;
}

sub allow {
	my ($self,@commands) = @_;

	# Allow each command.
	foreach my $cmd (@commands) {
		delete $self->{deny}->{$cmd} if exists $self->{deny}->{$cmd};
		$self->{allow}->{$cmd} = 1;
	}

	$self->deny_type ('allow_some') unless $self->{cusdeny} == 1;
}

sub check {
	my ($self,$file) = @_;

	open (FILE, $file) or return 0;
	my @data = ;
	close (FILE);

	# Handle dos text files on Mac and Unix
	if($/ ne "\r\n") {
		local $/ = "\r\n";
		chomp @data;
	}

	chomp @data;

	# Go through each line.
	my $num = 0;
	foreach my $line (@data) {
		$num++;
		next if length $line == 0;
		next if $line =~ /^\//;
		$line =~ s/^\s+//g;
		$line =~ s/^\t+//g;
		$line =~ s/^\s//g;
		$line =~ s/^\t//g;

		my ($cmd,$data) = split(//, $line, 2);
		$data =~ s/^\s+//g;
		$data =~ s/^\s//g;

		next unless length $cmd > 0;

		# Denied/Not allowed?
		if ($self->{denytype} ne 'allow_all') {
			if ($self->{denytype} eq 'deny_some') {
				if (exists $self->{deny}->{$cmd}) {
					die "Command $cmd is not allowed at $file line $num; ";
				}
			}
			elsif ($self->{denytype} eq 'allow_some') {
				if (!exists $self->{allow}->{$cmd}) {
					die "Command $cmd not in allowlist at $file line $num; ";
				}
			}
		}
		elsif ($self->{denytype} eq 'deny_all') {
			die "No commands allowed at $file line $num; ";
		}

		if ($cmd eq '>') {
			my @args = split(/\s+/, $data);
			if (scalar(@args) != 2) {
				die "Bad number of arguments in >LABEL at $file line $num; ";
			}
		}
		elsif ($cmd eq '<') {
			my @args = split(/\s+/, $data);
			if (scalar(@args) != 1) {
				die "Bad number of arguments in
			}
		}
		elsif ($cmd eq '+') {
			# On strict: must be lowercase, simplistic.
			if ($self->{syntax} eq 'strict') {
				if ($data =~ /[^a-z0-9 \*]/) {
					die "+TRIGGERS must be lowercase alphanumeric "
						. "while in 'strict' syntax at $file line $num; ";
				}
			}
			elsif ($self->{syntax} eq 'loose') {
				if ($data =~ /[^A-Za-z0-9 \*]/) {
					warn "+TRIGGERS must be alphanumeric while in 'loose' "
						. "syntax at $file line $num; ";
				}
			}
		}
		elsif ($cmd eq '%') {
			# On strict: must be lowercase, simplistic.
			if ($self->{syntax} eq 'strict') {
				if ($data =~ /[^a-z0-9 ]/) {
					die "+TRIGGERS must be lowercase alphanumeric "
						. "while in 'strict' syntax at $file line $num; ";
				}
			}
			elsif ($self->{syntax} eq 'loose') {
				if ($data =~ /[^A-Za-z0-9 ]/) {
					warn "+TRIGGERS must be alphanumeric while in 'loose' "
						. "syntax at $file line $num; ";
				}
			}
		}
		elsif ($cmd eq '-') {
			if (length $data == 0) {
				die "Empty -RESPONSE data at $file line $num; ";
			}
		}
		elsif ($cmd eq '^') {
			if (length $data == 0) {
				die "Empty ^CONTINUE data at $file line $num; ";
			}
		}
		elsif ($cmd eq '@') {
			if ($self->{syntax} eq 'strict') {
				if ($data =~ /[^a-z0-9 \*\<\>]/) {
					die "\@REDIRECTIONS must be lowercase alphanumeric "
						. "while in 'strict' syntax at $file line $num; ";
				}
			}
			elsif ($self->{syntax} eq 'loose') {
				if ($data =~ /[^A-Za-z0-9 \*\<\>]/) {
					die "\@REDIRECTIONS must be alphanumeric while in 'loose' "
						. "syntax at $file line $num; ";
				}
			}
		}
		elsif ($cmd eq '*') {
			if ($data !~ /^(.*?)=(.*?)::(.*?)$/i) {
				die "Syntax error at *CONDITION at $file line $num; ";
			}
		}
		elsif ($cmd eq '&') {
			if (length $data == 0) {
				die "Empty &HOLDER data at $file line $num; ";
			}
		}
		elsif ($cmd eq '#') {
			if (length $data == 0) {
				die "Empty #CODE data at $file line $num; ";
			}
		}
		elsif ($cmd eq '/') {
			# Comment data.
		}
		elsif ($cmd eq '~') {
			# A regexp. Leave it be.
		}
		else {
			warn "Unknown command '$cmd' with data '$data' at $file line $num; ";
		}
	}

	return 1;
}

1;
__END__