Lock down especially vulnerable internals of Type::Tiny subclasses using Internals::SvREADONLY

8 files changed, 58 insertions, 1 deletions

diff --git a/lib/Type/Tiny.pm b/lib/Type/Tiny.pm
index 78d6eb39..aef1e984 100644
--- a/lib/Type/Tiny.pm
+++ b/lib/Type/Tiny.pm
@@ -364,9 +364,20 @@ sub new {
 			) for keys %{ $params{my_methods} };
 	} #/ if ( $params{my_methods...})
 	
+	# In general, mutating a type constraint after it's been created
+	# is a bad idea and will probably not work. However some places are
+	# especially harmful and can lead to confusing errors, so allow
+	# subclasses to lock down particular keys.
+	#
+	$self->_lockdown( sub {
+		&Internals::SvREADONLY( $_, !!1 ) for @_;
+	} );
+	
 	return $self;
 } #/ sub new
 
+sub _lockdown {}
+
 sub DESTROY {
 	my $self = shift;
 	delete( $ALL_TYPES{ $self->{uniq} } );
diff --git a/lib/Type/Tiny/Duck.pm b/lib/Type/Tiny/Duck.pm
index 67b30462..21484dff 100644
--- a/lib/Type/Tiny/Duck.pm
+++ b/lib/Type/Tiny/Duck.pm
@@ -15,7 +15,6 @@ use Scalar::Util qw< blessed >;
 
 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
 
-
 use Exporter::Tiny 1.004001 ();
 use Type::Tiny::ConstrainedObject ();
 our @ISA = qw( Type::Tiny::ConstrainedObject Exporter::Tiny );
@@ -58,6 +57,11 @@ sub new {
 	return $proto->SUPER::new( %opts );
 } #/ sub new
 
+sub _lockdown {
+	my ( $self, $callback ) = @_;
+	$callback->( $self->{methods} );
+}
+
 sub methods { $_[0]{methods} }
 sub inlined { $_[0]{inlined} ||= $_[0]->_build_inlined }
 
diff --git a/lib/Type/Tiny/Enum.pm b/lib/Type/Tiny/Enum.pm
index c6dad7bb..c5f990c3 100644
--- a/lib/Type/Tiny/Enum.pm
+++ b/lib/Type/Tiny/Enum.pm
@@ -84,6 +84,11 @@ sub new {
 	return $proto->SUPER::new( %opts );
 } #/ sub new
 
+sub _lockdown {
+	my ( $self, $callback ) = @_;
+	$callback->( $self->{values}, $self->{unique_values} );
+}
+
 sub new_union {
 	my $proto  = shift;
 	my %opts   = ( @_ == 1 ) ? %{ $_[0] } : @_;
diff --git a/lib/Type/Tiny/Intersection.pm b/lib/Type/Tiny/Intersection.pm
index f3b36708..87969ed5 100644
--- a/lib/Type/Tiny/Intersection.pm
+++ b/lib/Type/Tiny/Intersection.pm
@@ -85,6 +85,11 @@ sub new {
 	return $proto->SUPER::new( %opts );
 } #/ sub new
 
+sub _lockdown {
+	my ( $self, $callback ) = @_;
+	$callback->( $self->{type_constraints} );
+}
+
 sub type_constraints { $_[0]{type_constraints} }
 sub constraint       { $_[0]{constraint} ||= $_[0]->_build_constraint }
 
diff --git a/lib/Type/Tiny/Union.pm b/lib/Type/Tiny/Union.pm
index f097eda7..0053d6a5 100644
--- a/lib/Type/Tiny/Union.pm
+++ b/lib/Type/Tiny/Union.pm
@@ -87,6 +87,11 @@ sub new {
 	return $self;
 } #/ sub new
 
+sub _lockdown {
+	my ( $self, $callback ) = @_;
+	$callback->( $self->{type_constraints} );
+}
+
 sub type_constraints { $_[0]{type_constraints} }
 sub constraint       { $_[0]{constraint} ||= $_[0]->_build_constraint }
 
diff --git a/t/20-modules/Type-Tiny-Enum/basic.t b/t/20-modules/Type-Tiny-Enum/basic.t
index b3859f59..701cb6fe 100644
--- a/t/20-modules/Type-Tiny-Enum/basic.t
+++ b/t/20-modules/Type-Tiny-Enum/basic.t
@@ -24,6 +24,7 @@ use warnings;
 use lib qw( ./lib ./t/lib ../inc ./inc );
 
 use Test::More;
+use Test::Fatal;
 use Test::TypeTiny;
 use Type::Utils qw< enum >;
 
@@ -59,6 +60,18 @@ is_deeply(
 	'FBB->values retains order',
 );
 
+is_deeply(
+	[@{ +FBB }],
+	[qw/foo bar baz/],
+	'overload retains order',
+);
+
+isnt(
+	exception { push @{ +FBB }, 'quux' },
+	undef,
+	'cannot push to overloaded arrayref'
+);
+
 use Scalar::Util qw(refaddr);
 
 is(
diff --git a/t/20-modules/Type-Tiny-Intersection/basic.t b/t/20-modules/Type-Tiny-Intersection/basic.t
index 433f3b9d..dc8acf74 100644
--- a/t/20-modules/Type-Tiny-Intersection/basic.t
+++ b/t/20-modules/Type-Tiny-Intersection/basic.t
@@ -28,6 +28,7 @@ use warnings;
 use lib qw( ./lib ./t/lib ../inc ./inc );
 
 use Test::More;
+use Test::Fatal;
 use Test::TypeTiny;
 
 use BiggerLib qw( :types );
@@ -108,4 +109,10 @@ should_pass(2, $SmallEven);
 should_fail(20, $SmallEven);
 should_fail(3, $SmallEven);
 
+isnt(
+	exception { push @{ $SmallEven }, 'quux' },
+	undef,
+	'cannot push to overloaded arrayref'
+);
+
 done_testing;
diff --git a/t/20-modules/Type-Tiny-Union/basic.t b/t/20-modules/Type-Tiny-Union/basic.t
index 8ed95dd3..7426a637 100644
--- a/t/20-modules/Type-Tiny-Union/basic.t
+++ b/t/20-modules/Type-Tiny-Union/basic.t
@@ -28,6 +28,7 @@ use warnings;
 use lib qw( ./lib ./t/lib ../inc ./inc );
 
 use Test::More;
+use Test::Fatal;
 use Test::TypeTiny;
 
 use BiggerLib qw( :types );
@@ -117,6 +118,12 @@ my $c2 = union [
 	class_type({ class => "Local::C" }),
 ];
 
+isnt(
+	exception { push @{ $c2 }, 'quux' },
+	undef,
+	'cannot push to overloaded arrayref'
+);
+
 ok(
 	$c2->parent == Types::Standard::Object(),
 	"can climb up parents of union type constraints to find best common ancestor (again)",