view release on metacpan or  search on metacpan

lib/Acme/Perl/Consensual.pm  view on Meta::CPAN

package Acme::Perl::Consensual;

use 5;
use strict;
use POSIX qw(mktime floor);

BEGIN {
	$Acme::Perl::Consensual::AUTHORITY = 'cpan:TOBYINK';
	$Acme::Perl::Consensual::VERSION   = '0.002';
};

# Mostly sourced from
# http://upload.wikimedia.org/wikipedia/commons/4/4e/Age_of_Consent_-_Global.svg
my %requirements = (
	bo => { puberty => 1 },
	ao => { age => 12 },
	(map { $_ => { age => 13 } } qw(
		ar bf es jp km kr ne
	)),
	(map { $_ => { age => 14 } } qw(
		al at ba bd bg br cl cn co de 
		ec ee hr hu it li me mg mk mm 
		mo mw pt py rs sl sm td va
	)),
	(map { $_ => { age => 15 } } qw(
		aw cr cw cz dk fo fr gf gl gn 
		gp gr hn is kh ki kp la mc mf 
		mq pf pl re ro sb se si sk sx 
		sy tf th tv uy vc wf
	)),
	(map { $_ => { age => 16 } } qw(
		ad ag am as ax az bb be bh bm 
		bn bq bs bw by bz ca cc ch ck 
		cm cu dm dz fi fj gb ge gh gi 
		gu gw gy hk il im in je jm jo 
		ke kg kn ky kz lc lk ls lt lu 
		lv md mh mn mr ms mu my mz na 
		nf nl no np nz pg pn pr pw ru 
		sg sj sn sr sz tj tm to tt tw 
		ua um uz ve vu ws za zm zw
	)),
	(map { $_ => { age => 17 } } qw(
		cy ie nr
	)),
	(map { $_ => { age => 18 } } qw(
		bi bj bt cd dj do eg er et ga 
		gm gq gt ht lb lr ma ml mt ng 
		ni pa pe ph ss rw sc sd so sv 
		tr tz ug vi vn
	)),
	id => { age => 19 },
	tn => { age => 20 },
	(map { $_ => { married => 1 } } qw(
		ae af ir kw mv om pk qa sa ye
	)),
	(map { $_ => undef } qw(
		ai bl bv cf cg ci cv cx eh fk 
		fm gd gg hm io iq ly mp nc nu 
		pm ps sh st tc tg tl vg
	)),
	# There are US federal laws, but they're fairly complicated for a little
	# module like this to assess, and the state laws (below) are generally
	# more relevant.
	us => undef,
	(map { ;"us-$_" => { age => 16 } } qw(
		al ak ar ct dc ga hi id ia ks
		ky me md ma mi mn ms mt nv nh
		nj nc oh ok ri sc sd vt wa wv
	)),
	(map { ;"us-$_" => { age => 17 } } qw(
		co il la mo ne nm ny tx wy
	)),
	(map { ;"us-$_" => { age => 18 } } qw(
		az ca de fl id nd or tn ut va
		wi pa
	)),
	# Australian federal laws apply to Australian citizens while outside
	# Australia; while inside Australia only state laws are relevant.
	au => undef,
	(map { ;"au-$_" => { age => 16 } } qw(
		act nsw nt qld vic wa
	)),
	(map { ;"au-$_" => { age => 17 } } qw(
		sa tas
	)),
	mx => { age => 12 },
	(map { ;"mx-$_" => { age => 12 } } qw(
		agu bcs cam chp coa dif gua gro
		hid jal mic mor oax pue que roo
		slp sin son tab 
	)),
	(map { ;"mx-$_" => { age => 13 } } qw(
		yuc zac
	)),
	(map { ;"mx-$_" => { age => 14 } } qw(
		bcn chh col dur nle tla ver
	)),
	"mx-mex" => { age => 15 },
	"mx-nay" => { puberty => 1 },
);

my %perlhist;

sub new
{
	my ($class, %args) = @_;
	$args{locale} = $ENV{LC_ALL} || $ENV{LC_LEGAL} || 'en_XX.UTF-8'
		unless exists $args{locale};
	$args{locale} = $1
		if $args{locale} =~ /^.._(.+?)(\.|$)/;
	bless \%args => $class;
}

sub locale
{
	lc shift->{locale};
}

sub can
{
	if (@_ == 2 and not ref $_[1])
	{
		shift->SUPER::can(@_);
	}
	else
	{
		shift->_can_consent(@_);
	}
}

sub _can_consent
{
	my $self     = ref $_[0] ? shift : shift->new;
	
	my $provides = ref $_[0] ? shift : +{@_};
	my $requires = $requirements{ $self->locale };
	
	# If locale includes a region, fallback to country.
	if ($self->locale =~ /^([a-z]{2})-/)
	{
		$requires ||= $requirements{ $1 };
	}
	
	return undef unless defined $requires;
	
	for (keys %$requires)
	{
		return undef unless defined $provides->{$_};
		return !1 unless $provides->{$_} >= $requires->{$_};
	}
	
	!0;
}

sub age_of_perl