On 2013-08-02T09:50:57+01:00, TIMB wrote:
Show quoted text> I think it'll cause problems with type inheritance.
Point taken. I've taken a slightly different approach that makes it easy to recycle non-locked types into locked types.
use Types::Standard qw( Dict Int );
use Types::ReadOnly qw( Locked );
my $dict = Dict[ n => Int ];
my $locked_dict = Locked[ $dict ];
Using is_a_type_of, $locked_dict appears to inherit from both $dict and Locked. Using is_strictly_a_type_of, it inherits from $dict.
I haven't done coercions or inlining yet, but I think this approach seems reasonable.
use strict;
use warnings;
use Time::Limit;
use Test::More;
use Test::Fatal;
use Test::TypeTiny;
# Declared inline; don't try to load these thanks!
no thanks 'Types::ReadOnly', 'Type::Tiny::Wrapped', 'Type::Tiny::Wrapper';
BEGIN {
package Type::Tiny::Wrapped;
use base 'Type::Tiny';
sub wrap {
my $class = shift;
my $type = Types::TypeTiny::to_TypeTiny($_[0]);
my $wrapper = $_[1];
my $self = bless($type->create_child_type => $class);
$self->{wrapper} = $wrapper;
$self->{display_name} = sprintf('%s[%s]', $wrapper->display_name, $type->display_name);
return $self;
}
sub wrapper { $_[0]{wrapper} }
sub pre_check { $_[0]{wrapper}{pre_check} }
sub pre_coerce { $_[0]{wrapper}{pre_coerce} }
sub post_check { $_[0]{wrapper}{post_check} }
sub post_coerce { $_[0]{wrapper}{post_coerce} }
sub _build_compiled_check {
my $self = shift;
my $pre = $self->pre_check;
my $orig = $self->parent->compiled_check(@_);
my $post = $self->post_check;
return $orig unless $pre || $post;
return sub {
local $_ = $_[0];
return if defined($pre) && !$pre->(@_);
return if !$orig->(@_);
return if defined($post) && !$post->(@_);
return !!1;
};
}
sub _strict_check {
my $self = shift;
local $_ = $_[0];
my $pre = $self->pre_check;
my $post = $self->post_check;
return if defined($pre) && !$pre->(@_);
return if !$self->parent->_strict_check(@_);
return if defined($post) && !$post->(@_);
return !!1;
}
sub is_subtype_of {
my $self = shift;
$self->wrapper->is_a_type_of(@_) or $self->SUPER::is_subtype_of(@_);
}
sub inline_check {
...;
}
sub can_be_inlined {
0;
}
};
BEGIN {
package Type::Tiny::Wrapper;
use base 'Type::Tiny';
use Scalar::Util 'weaken';
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
Type::Tiny::_croak("Type::Tiny::Wrapper types must not have a constraint!")
unless $self->_is_null_constraint;
return $self;
}
my @FIELDS = qw/ pre_check pre_coerce post_check post_coerce /;
sub pre_check { $_[0]{'pre_check'} }
sub pre_coerce { $_[0]{'pre_coerce'} }
sub post_check { $_[0]{'post_check'} }
sub post_coerce { $_[0]{'post_coerce'} }
sub child_type_class { +__PACKAGE__ }
sub create_child_type {
my $self = shift;
$self->SUPER::create_child_type(
( map {
exists($self->{$_}) ? ($_ => $self->{$_}) : ()
} @FIELDS ),
@_,
);
}
sub has_constraint_generator { 1 }
sub constraint_generator {
my $self = shift;
weaken $self;
return sub { 'Type::Tiny::Wrapped'->wrap(shift, $self) };
}
};
BEGIN {
package Types::ReadOnly;
use Types::Standard qw(Any);
use Type::Utils;
use Type::Library -base, -declare => qw(Locked);
use Hash::Util qw( hashref_locked lock_ref_keys );
declare Locked,
bless => 'Type::Tiny::Wrapper',
pre_check => sub { hashref_locked($_) },
;
};
use Data::Dumper;
use Types::Standard -types;
use Types::ReadOnly -types;
use Hash::Util qw( hashref_locked lock_ref_keys );
my $my_hash = HashRef[ Undef ];
my $my_lock = Locked[ $my_hash ];
isa_ok(Locked, 'Type::Tiny::Wrapper');
isa_ok($my_lock, 'Type::Tiny::Wrapped');
ok( $my_lock->is_a_type_of(Locked), '$my_lock->is_a_type_of(Locked)');
ok( $my_lock->is_a_type_of($my_hash), '$my_lock->is_a_type_of($my_hash)');
ok(!$my_lock->is_strictly_a_type_of(Locked), '!$my_lock->is_strictly_a_type_of(Locked)');
ok( $my_lock->is_strictly_a_type_of($my_hash), '$my_lock->is_strictly_a_type_of($my_hash)');
my $hash1 = { foo => undef };
my $hash2 = { foo => undef }; lock_ref_keys($hash2);
my $hash3 = { foo => "xxx" }; lock_ref_keys($hash3);
like(
exception { my $bar = $hash2->{bar} },
qr{^Attempt to access disallowed key 'bar' in a restricted hash},
'hashes can be locked',
);
should_pass($hash1, $my_hash);
should_pass($hash2, $my_hash);
should_fail($hash3, $my_hash);
should_fail($hash1, $my_lock);
should_pass($hash2, $my_lock);
should_fail($hash3, $my_lock);
done_testing;
