File Coverage

blib/lib/Lingua/Boolean/Tiny.pm

Criterion	Covered	Total	%
statement	154	199	77.3
branch	27	34	79.4
condition	1	3	33.3
subroutine	82	110	74.5
pod	5	5	100.0
total	269	351	76.6

use 5.006002;
use strict;
use warnings;
use utf8;
no warnings qw( void once uninitialized );

{
	package Lingua::Boolean::Tiny;

	require Exporter;
	our @ISA = 'Exporter';

	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.008';
	our @EXPORT    = qw( boolean );
	our (%LANG, @LANG);
	our @BASELANG  = qw( zh en es hi ru ar pt bn fr ms de ja );

	sub new
	{
		require Carp;
		my $class = shift;
		my $self  = $class->new_strict(@_)
			or Carp::carp("Language not available, using English instead");
		$self || "Lingua::Boolean::Tiny"->new_strict("en");
	}

	sub new_strict
	{
		shift;
		my ($lang) = @_;
		return "Lingua::Boolean::Tiny::Union"->new(@$lang) if ref($lang);
		return "Lingua::Boolean::Tiny::Union"->new(@BASELANG) if !defined $lang;
		my $class = $LANG{ lc $lang }
			|| do { require Lingua::Boolean::Tiny::More; $LANG{ lc $lang } };
		return $class->new if $class;
		return;
	}

	sub boolean
	{
		my $text = shift;
		my $lang = __PACKAGE__->new(@_ ? $_[0] : \@LANG);
		$lang->boolean($text);
	}

	sub langs
	{
		@LANG;
	}

	sub languages
	{
		map __PACKAGE__->new($_)->languages, @LANG;
	}
}

{
	package Lingua::Boolean::Tiny::BASE;

	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.008';

	# Versions of ~~ and fc for legacy Perls...
	use if $] >= 5.016, feature => 'fc';
	BEGIN { eval q[fc("1")] or eval q[sub fc($) { lc $_[0] }] };

	eval q
	{
		use match::simple qw(match);
		1;
	}
	or eval q
	{
		use v5.10.1;
		no warnings;
		sub match { $_[0] ~~ $_[1] };
		1;
	}
	or eval q
	{
		sub match
		{
			my ($a, $b) = @_;
			if (ref($b) eq 'ARRAY')
			{
				for my $b2 (@$b)
				{
					return 1 if match($a, $b2);
				}
			}
			ref($b) eq 'Regexp' and return $a =~ $b;
			ref($b) eq 'CODE'   and return $b->($a);
			return $a eq $b;
		}
	};

	sub boolean
	{
		my $self = shift;
		my ($text) = @_;

		$text =~ s/(?:^\s+)|(?:\s+$)//gs;

		return 1 if fc $text eq fc $self->yes;
		return 0 if fc $text eq fc $self->no;
		return 1 if match($text, $self->yes_expr);
		return 0 if match($text, $self->no_expr);
		return 1 if $text eq 1;
		return 0 if $text eq 0;
		return undef;
	}

	sub yesno
	{
		$_[1] ? $_[0]->yes : $_[0]->no
	}

	sub make_classes
	{
		my $base = shift;
		no strict 'refs';
		for (@_)
		{
			my ($lang, $codes, $yes, $no, $yes_expr, $no_expr) = @$_;
			$yes_expr = $yes unless defined $yes_expr;
			$no_expr  = $no  unless defined $no_expr;
			my $class = "Lingua::Boolean::Tiny::$lang";
			${"$class\::AUTHORITY"} = $AUTHORITY;
			${"$class\::VERSION"}   = $VERSION;
			@{"$class\::ISA"}       = ($base);
			no warnings qw( closure );
			eval qq
			{
				package $class;
				sub new       { my \$k = shift; bless qr{$lang}, \$k };
				sub yes       { \$yes };
				sub no        { \$no };
				sub yes_expr  { \$yes_expr };
				sub no_expr   { \$no_expr };
				sub languages { \$lang };
				sub langs     { \@{ \$codes } };
			};
			for my $lang (@$codes)
			{
				$Lingua::Boolean::Tiny::LANG{$lang} = $class;
			}
			push @Lingua::Boolean::Tiny::LANG, $codes->[0];
		}

		return 1;
	}
}

{
	package Lingua::Boolean::Tiny::Union;

	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.008';

	sub new
	{
		my $class = shift;
		bless [ grep defined, map "Lingua::Boolean::Tiny"->new_strict($_), @_ ] => $class;
	}

	sub boolean
	{
		my $self = shift;
		for (@$self)
		{
			my $r = $_->boolean(@_);
			return $r if defined $r;
		}
		return undef;
	}

	sub langs
	{
		my $self = shift;
		map $_->langs, @$self;
	}

	sub languages
	{
		my $self = shift;
		map $_->languages, @$self;
	}
}

"Lingua::Boolean::Tiny::BASE"->make_classes(
	[
		Chinese => [qw( zh zho chi )],
		q/是/ => q/不是/,
		[qr{^[yY是]}, qw( 是 對 是 对 ), qr{^[ds]h[ìi]$}i],
		[qr{^[nN不否]}, qw( 不是 不對 不是 不对 ), qr{^b[úu]\s*[ds]h[ìi]$}i],
	],
	[
		English => [qw( en eng )],
		qw( yes no ),
		[qr{^y(?:es)?$}i, qr{^on$}i, qr{^ok$}i, qr{^true$}i],
		[qr{^no?$}i, qr{^off$}i, qr{not ?ok$}i, qr{^false$}i],
	],
	[
		Spanish => [qw( es spa )],
		qw( sí no ),
		qr{^[sSyY]},
		qr{^[nN]$},
	],
	[
		Hindi => [qw( hi hin )],
		q/हाँ/ => q/नहीं/,
		["हाँ", qr{^h[aā]̃$}i, "जी", qr{^j[īi]$}i, "जी हाँ", qr{^j[īi]\s*h[aā]̃$}i, qr{^ji\s*ha$}i, qr{^[yY]}],
		["नहीं", qr{^nahī̃$}i, "जी नहीं", qr{^jī nahī̃$}i, qr{^ji\s*nahi$}i, qr{^[nN]}],
	],
	[
		Russian => [qw( ru rus )],
		qw( да нет ),
		[qr{^[ДдYy]}, qr{^да$}i, qr{^da$}i],
		[qr{^[НнNn]}, qr{^нет$}i, qr{^n[iy]?et$}i],
	],
	[
		Arabic => [qw( ar ara )],
		q/نعم/ => q/ﻻ/,
		qr{^[نyY].*},
		qr{^[لnN].*},
	],
	[
		Portuguese  => [qw( pt por )],
		qw( sim não ),
		[qr{^[SsyY].*}, qr{^sim$}i],
		[qr{^[nN].*}, qr{^n[aã]o$}i],
	],
	[
		Bengali => [qw( bn ben )],
		q/হ্যাঁ/ => q/না/,
		[qr{^[হ্যাঁyY]}, q/জি/, q/হ্যাঁ/, qr{^ji$}i, qr{^h[eê][nñ]$}i],
		[qr{^[নাnN]}, q/না/, qr{^n[aā]$}i],
	],
	[
		French => [qw( fr fre fra )],
		qw( oui non ),
		[qr{^[oOjJyYsS1].*}, qr{^oui$}i, qr{^ok$}i, qr{^vraie?$}i],
		[qr{^[nN0].*}, qr{^n(?:on?)?$}i, qr{^faux$}i],
	],
	[
		Malay => [qw( ms may msa )],
		qw( ya tidak ),
		[qr{^[Yy]}, qr{^ya$}i, qr{^ha'?ah$}i],
		[qr{^[Tt]}, qr{^tidak$}i, qr{^tak$}i],
	],
	[
		German => [qw( de deu ger )],
		qw( ja nein ),
		[qr{^[jJyY].*}, qr{^ja?$}i, qr{^wahr$}i],
		[qr{^[nN].*}, qr{^n(?:ein)?$}i, qr{^falsche$}i],
	],
	[
		Japanese => [qw( ja jpn )],
		q/はい/ => q/いいえ/,
		[qr{^([yYｙＹ]|はい|ハイ)}, q/はい/, q/ええ/, q/うん/, qr{^hai$}i, qr{^[eē]$}i, qr{^un$}i, qr{^n̄$}i],
		[qr{^([nNｎＮ]|いいえ|イイエ)}, q/いいえ/, q/いえ/, q/ううん/, q/違う/, qr{^[íi]?ie$}i, qr{^uun$}i, qr{^[n̄n]n$}i, qr{^chigau$}i],
	],
);

__END__