[libtype-tiny-perl] 02/06: my_methods stuff

[Jonas Smedegaard]

This is an automated email from the git hooks/post-receive script.

js pushed a commit to tag 0.043_02
in repository libtype-tiny-perl.

commit 3686bdd54d47447cb3b3017e53272e823384d94c
Author: Toby Inkster <mail at tobyinkster.co.uk>
Date:   Thu Apr 10 12:02:33 2014 +0100

    my_methods stuff
---
 lib/Type/Tiny.pm                  | 57 +++++++++++++++++++++++++++++++++++----
 lib/Type/Tiny/Manual/Policies.pod |  5 ++++
 t/20-unit/Type-Tiny/my-methods.t  | 39 +++++++++++++++++++++++++++
 3 files changed, 96 insertions(+), 5 deletions(-)

diff --git a/lib/Type/Tiny.pm b/lib/Type/Tiny.pm
index 2092a63..64d6efa 100644
--- a/lib/Type/Tiny.pm
+++ b/lib/Type/Tiny.pm
@@ -254,6 +254,7 @@ sub parameters               { $_[0]{parameters} }
 sub moose_type               { $_[0]{moose_type}     ||= $_[0]->_build_moose_type }
 sub mouse_type               { $_[0]{mouse_type}     ||= $_[0]->_build_mouse_type }
 sub deep_explanation         { $_[0]{deep_explanation} }
+sub my_methods               { $_[0]{my_methods}     ||= $_[0]->_build_my_methods }
 
 sub has_parent               { exists $_[0]{parent} }
 sub has_library              { exists $_[0]{library} }
@@ -977,10 +978,33 @@ sub isa
 	{
 		return !!1;
 	}
-
+	
 	$self->SUPER::isa(@_);
 }
 
+sub _build_my_methods
+{
+	return {};
+}
+
+sub _lookup_my_method
+{
+	my $self = shift;
+	my ($name) = @_;
+	
+	if ($self->my_methods->{$name})
+	{
+		return $self->my_methods->{$name};
+	}
+	
+	if ($self->has_parent)
+	{
+		return $self->parent->_lookup_my_method(@_);
+	}
+	
+	return;
+}
+
 sub can
 {
 	my $self = shift;
@@ -990,9 +1014,18 @@ sub can
 	my $can = $self->SUPER::can(@_);
 	return $can if $can;
 	
-	if ($INC{"Moose.pm"} and ref($self) and my $method = $self->moose_type->can(@_))
+	if (ref($self))
 	{
-		return sub { $method->(shift->moose_type, @_) };
+		if ($INC{"Moose.pm"})
+		{
+			my $method = $self->moose_type->can(@_);
+			return sub { shift->moose_type->$method(@_) };
+		}
+		if ($_[0] =~ /\Amy_(.+)\z/)
+		{
+			my $method = $self->_lookup_my_method($1);
+			return $method if $method;
+		}
 	}
 	
 	return;
@@ -1004,9 +1037,18 @@ sub AUTOLOAD
 	my ($m) = (our $AUTOLOAD =~ /::(\w+)$/);
 	return if $m eq 'DESTROY';
 	
-	if ($INC{"Moose.pm"} and ref($self) and my $method = $self->moose_type->can($m))
+	if (ref($self))
 	{
-		return $method->($self->moose_type, @_);
+		if ($INC{"Moose.pm"})
+		{
+			my $method = $self->moose_type->can($m);
+			return $self->moose_type->$method(@_) if $method;
+		}
+		if ($m =~ /\Amy_(.+)\z/)
+		{
+			my $method = $self->_lookup_my_method($1);
+			return $self->$method(@_) if $method;
+		}
 	}
 	
 	_croak q[Can't locate object method "%s" via package "%s"], $m, ref($self)||$self;
@@ -1187,6 +1229,11 @@ You may pass C<< coercion => 1 >> to the constructor to inherit coercions
 from the constraint's parent. (This requires the parent constraint to have
 a coercion.)
 
+=item C<< my_methods >>
+
+Experimenal hashref of additional methods that can be called on the type
+constraint object.
+
 =back
 
 =head3 Attributes related to parameterizable and parameterized types
diff --git a/lib/Type/Tiny/Manual/Policies.pod b/lib/Type/Tiny/Manual/Policies.pod
index e995308..4fbc3d3 100644
--- a/lib/Type/Tiny/Manual/Policies.pod
+++ b/lib/Type/Tiny/Manual/Policies.pod
@@ -54,6 +54,11 @@ This is experimental. See L<Type::Utils>.
 
 =item *
 
+L<Type::Tiny>'s C<my_methods> attribute and the functionality it
+provides is experimental.
+
+=item *
+
 The L<parameterizable coercion API|Type::Coercion> is subject to change.
 
 =item *
diff --git a/t/20-unit/Type-Tiny/my-methods.t b/t/20-unit/Type-Tiny/my-methods.t
new file mode 100644
index 0000000..ce233ca
--- /dev/null
+++ b/t/20-unit/Type-Tiny/my-methods.t
@@ -0,0 +1,39 @@
+=pod
+
+=encoding utf-8
+
+=head1 PURPOSE
+
+Checks Type::Tiny's C<my_methods> attribute.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink at cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2014 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+use strict;
+use warnings;
+use lib qw( ./lib ./t/lib ../inc ./inc );
+use Test::More;
+
+use Types::Standard qw(Num);
+
+my $type = Num->create_child_type(
+	name         => 'Number',
+	my_methods   => { round_off => sub { int($_[1]) } }
+);
+
+my $type2 = $type->create_child_type(name => 'Number2');
+
+can_ok($_, 'my_round_off') for $type, $type2;
+is($_->my_round_off(42.3), 42, "$_ my_round_off works") for $type, $type2;
+
+done_testing;

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libtype-tiny-perl.git