File Coverage

blib/lib/Types/ReadOnly.pm

Criterion	Covered	Total	%
statement	44	46	95.6
branch	7	10	70.0
condition	9	15	60.0
subroutine	12	12	100.0
pod			n/a
total	72	83	86.7

use 5.008;
use strict;
use warnings;

package Types::ReadOnly;

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

use Type::Tiny 0.022 ();
use Types::Standard qw( Any Dict );
use Type::Utils;
use Type::Library -base, -declare => qw( ReadOnly Locked );

use Scalar::Util qw( reftype blessed );

sub _dclone($) {
	require Storable;
	no warnings 'redefine';
	*_dclone = \&Storable::dclone;
	goto &Storable::dclone;
}

my %skip = map { $_ => 1 } qw/CODE GLOB/;
sub _make_readonly {
	my (undef, $dont_clone) = @_;
	if (my $reftype = reftype $_[0] and not blessed($_[0]) and not &Internals::SvREADONLY($_[0])) {
		$_[0] = _dclone($_[0]) if !$dont_clone && &Internals::SvREFCNT($_[0]) > 1 && !$skip{$reftype};
		&Internals::SvREADONLY($_[0], 1);
		if ($reftype eq 'SCALAR' || $reftype eq 'REF') {
			_make_readonly(${ $_[0] }, 1);
		}
		elsif ($reftype eq 'ARRAY') {
			_make_readonly($_) for @{ $_[0] };
		}
		elsif ($reftype eq 'HASH') {
			&Internals::hv_clear_placeholders($_[0]);
			_make_readonly($_) for values %{ $_[0] };
		}
	}
	Internals::SvREADONLY($_[0], 1);
	return;
}

our %READONLY_REF_TYPES = (HASH => 1, ARRAY => 1, SCALAR => 1, REF => 1);

declare ReadOnly,
	bless     => 'Type::Tiny::Wrapper',
	pre_check => sub
	{
		$READONLY_REF_TYPES{reftype($_)} and &Internals::SvREADONLY($_);
	},
	inlined_pre_check => sub
	{
		return (
			"\$Types::ReadOnly::READONLY_REF_TYPES{Scalar::Util::reftype($_)}",
			"&Internals::SvREADONLY($_)",
		);
	},
	post_coerce => sub
	{
		_make_readonly($_);
		return $_;
	},
	inlined_post_coerce => sub
	{
		"do { Types::ReadOnly::_make_readonly($_); $_ }";
	};

my $_FIND_KEYS = sub {
	my ($dict) = grep {
		$_->is_parameterized
			and $_->has_parent
			and $_->parent->strictly_equals(Dict)
	} $_[0], $_[0]->parents;
	return unless $dict;
	return if ref($dict->parameters->[-1]) eq q(HASH);
	my @keys = sort keys %{ +{ @{ $dict->parameters } } };
	return unless @keys;
	\@keys;
};

# Stolen from Hash::Util 0.15.
# In earlier versions, of Hash::Util, there is only a hashref_unlocked
# function, which happens to be very broken. :-/
sub _hashref_locked
{
	my $hash=shift;
	Internals::SvREADONLY(%$hash);
}

declare Locked,
	bless     => 'Type::Tiny::Wrapper',
	pre_check => sub
	{
		return unless reftype($_) eq 'HASH';
		return unless &Internals::SvREADONLY($_);

		my $type    = shift;
		my $wrapped = $type->wrapped;

		if (my $KEYS = $wrapped->$_FIND_KEYS) {
			require Hash::Util;
			my $keys  = join "*#*", @$KEYS;
			my $legal = join "*#*", sort(&Hash::Util::legal_keys($_));
			return if $keys ne $legal;
		}

		return !!1;
	},
	inlined_pre_check => sub
	{
		my @r;
		push @r, qq[Scalar::Util::reftype($_) eq 'HASH'];
		push @r, qq[&Internals::SvREADONLY($_)];

		my $type    = $_[0];
		my $wrapped = $type->wrapped;

		if (my $KEYS = $wrapped->$_FIND_KEYS) {
			require B;
			require Hash::Util;
			push @r, B::perlstring(join "*#*", @$KEYS)
				.qq[ eq join("*#*", sort(&Hash::Util::legal_keys($_)))||''];
		}

		return @r;
	},
	post_coerce => sub
	{
		require Hash::Util;

		my $type    = shift;
		my $wrapped = $type->wrapped;

		&Hash::Util::unlock_hash($_);
		&Hash::Util::lock_keys($_, @{ $wrapped->$_FIND_KEYS || [] });
		return $_;
	},
	inlined_post_coerce => sub
	{
		require Hash::Util;

		my $type    = shift;
		my $wrapped = $type->wrapped;

		my $qkeys = '';
		if (my $KEYS = $wrapped->$_FIND_KEYS) {
			require B;
			$qkeys = join q[,], '', map B::perlstring($_), @$KEYS;
		}

		"&Hash::Util::unlock_hash($_); &Hash::Util::lock_keys($_ $qkeys); $_;";
	};

1;

__END__