view release on metacpan or  search on metacpan

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

	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
{
	my $class = shift;
	return $class->age_of_perl_in_seconds(shift)
		/ 31_556_736 # 365.24 * 24 * 60 * 60
}

sub age_of_perl_in_seconds
{
	my ($class, $v) = @_;
	$v ||= $];
		
	my $pl_date = do
	{
		$class->_perlhist;
	
		my $date = $perlhist{$v};